home *** CD-ROM | disk | FTP | other *** search
/ EnigmA Amiga Run 1995 November / EnigmA AMIGA RUN 02 (1995)(G.R. Edizioni)(IT)[!][issue 1995-11][Skylink CD].iso / earcd / program / misc / obrn-a_1.lha / oberon-a / src_upd1.lha / source / oc / Compiler.mod next >
Text File  |  1995-07-13  |  68KB  |  2,276 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: Compiler.mod $
  4.   Description: Recursive-descent parser
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 5.31 $
  8.       $Author: fjc $
  9.         $Date: 1995/07/14 00:46:09 $
  10.  
  11.   Copyright © 1990-1993, ETH Zuerich
  12.   Copyright © 1993-1995, Frank Copeland
  13.   This module forms part of the OC program
  14.   See OC.doc for conditions of use and distribution
  15.  
  16.   Log entries are at the end of the file.
  17.  
  18. *************************************************************************)
  19.  
  20. <* STANDARD- *> <* MAIN- *>
  21.  
  22. MODULE Compiler;
  23.  
  24. IMPORT
  25.   SYS := SYSTEM, Kernel, Errors, e := Exec, ti := Timer, Str := Strings,
  26.   OberonClock, Files, OCM, OCS, OCT, OCC, OCI, OCE, OCP, OCH, OCStrings,
  27.   In, OCOut;
  28.  
  29.  
  30. (* --- Exported declarations ------------------------------------------ *)
  31.  
  32. VAR
  33.   newSF * : BOOLEAN;
  34.   returnError*, returnWarn* : BOOLEAN;
  35.  
  36.  
  37. (* --- Local declarations --------------------------------------------- *)
  38.  
  39. CONST
  40.  
  41.   NofCases = 128; RecDescSize = 8; AdrSize = OCM.PtrSize;
  42.   ProcSize = OCM.ProcSize; PtrSize = OCM.PtrSize; ParOrg = 2 * AdrSize;
  43.   LParOrg = 3 * AdrSize; XParOrg = 3 * AdrSize; ProcVarSize = 32768;
  44.  
  45.   ModNameLen = 26; (* Max. module name length, imposed by AmigaDOS *)
  46.  
  47. (* Symbols *)
  48.  
  49.   null    = OCS.null;    times  = OCS.times;  slash     = OCS.slash;
  50.   div     = OCS.div;     mod    = OCS.mod;    and       = OCS.and;
  51.   plus    = OCS.plus;    minus  = OCS.minus;  or        = OCS.or;
  52.   eql     = OCS.eql;     neq    = OCS.neq;    lss       = OCS.lss;
  53.   leq     = OCS.leq;     gtr    = OCS.gtr;    geq       = OCS.geq;
  54.   in      = OCS.in;      is     = OCS.is;     arrow     = OCS.arrow;
  55.   period  = OCS.period;  comma  = OCS.comma;  colon     = OCS.colon;
  56.   upto    = OCS.upto;    rparen = OCS.rparen; rbrak     = OCS.rbrak;
  57.   rbrace  = OCS.rbrace;  of     = OCS.of;     then      = OCS.then;
  58.   do      = OCS.do;      to     = OCS.to;     lparen    = OCS.lparen;
  59.   lbrak   = OCS.lbrak;   lbrace = OCS.lbrace; not       = OCS.not;
  60.   becomes = OCS.becomes; number = OCS.number; nil       = OCS.nil;
  61.   string  = OCS.string;  ident  = OCS.ident;  semicolon = OCS.semicolon;
  62.   bar     = OCS.bar;     end    = OCS.end;    else      = OCS.else;
  63.   elsif   = OCS.elsif;   until  = OCS.until;  if        = OCS.if;
  64.   case    = OCS.case;    while  = OCS.while;  repeat    = OCS.repeat;
  65.   loop    = OCS.loop;    with   = OCS.with;   exit      = OCS.exit;
  66.   return  = OCS.return;  array  = OCS.array;  record    = OCS.record;
  67.   pointer = OCS.pointer; begin  = OCS.begin;  const     = OCS.const;
  68.   type    = OCS.type;    var    = OCS.var;    procedure = OCS.procedure;
  69.   import  = OCS.import;  module = OCS.module; eof       = OCS.eof;
  70.   for = OCS.for; by = OCS.by;
  71.  
  72. (* object modes *)
  73.   Var = OCM.Var; Ind = OCM.Ind; Con = OCM.Con; Reg = OCM.Reg;
  74.   Fld = OCM.Fld; Typ = OCM.Typ; LProc = OCM.LProc; XProc = OCM.XProc;
  75.   SProc = OCM.SProc; TProc = OCM.TProc; Mod = OCM.Mod; Abs = OCM.Abs;
  76.   VarArg = OCM.VarArg; M2Proc = OCM.M2Proc; CProc = OCM.CProc;
  77.   AProc = OCM.AProc;
  78.  
  79. (* object modes for language extensions *)
  80.   LibCall = OCM.LibCall;
  81.  
  82.   (* System flags *)
  83.  
  84.   DefaultFlag = OCM.DefaultFlag; OberonFlag = OCM.OberonFlag;
  85.   M2Flag = OCM.M2Flag; CFlag = OCM.CFlag; BCPLFlag = OCM.BCPLFlag;
  86.   AsmFlag = OCM.AsmFlag;
  87.  
  88. (* structure forms *)
  89.   Undef = OCT.Undef; Byte = OCT.Byte; Bool = OCT.Bool; Char = OCT.Char;
  90.   SInt = OCT.SInt; Int = OCT.Int; LInt = OCT.LInt; Real = OCT.Real;
  91.   LReal = OCT.LReal; BSet = OCT.BSet; WSet = OCT.WSet; Set = OCT.Set;
  92.   String = OCT.String; NilTyp = OCT.NilTyp; NoTyp = OCT.NoTyp;
  93.   PtrTyp = OCT.PtrTyp; AdrTyp = OCT.AdrTyp; BPtrTyp = OCT.BPtrTyp;
  94.   Pointer = OCT.Pointer; ProcTyp = OCT.ProcTyp; Array = OCT.Array;
  95.   DynArr = OCT.DynArr; Record = OCT.Record;
  96.  
  97.   intSet    = {SInt, Int, LInt};
  98.   labeltyps = {Char, SInt, Int, LInt};
  99.  
  100.   NumLoopLevels = 16; MaxLoopLevel = NumLoopLevels - 1;
  101.  
  102. VAR
  103.  
  104.   sym, procNo : INTEGER;
  105.   LoopLevel, ExitNo : INTEGER;
  106.   LoopExit : ARRAY NumLoopLevels OF LONGINT;
  107.   defaultFlag : INTEGER;
  108.  
  109. VAR
  110.  
  111.   file, batchFile : Files.File;
  112.   r : Files.Rider;
  113.   tr : ti.TimeRequestPtr;
  114.  
  115. (* --- Procedure declarations ----------------------------------------- *)
  116.  
  117.  
  118. (*------------------------------------*)
  119. PROCEDURE^ Type (VAR typ : OCT.Struct; dynArr : BOOLEAN);
  120. PROCEDURE^ Expression (VAR x : OCT.Item);
  121. PROCEDURE^ Block
  122.   (proc : OCT.Object; VAR dsize : LONGINT; VAR retList : LONGINT);
  123.  
  124. (*------------------------------------*)
  125. PROCEDURE CheckSym (s : INTEGER);
  126.  
  127. BEGIN (* CheckSym *)
  128.   IF sym = s THEN OCS.Get (sym) ELSE OCS.Mark (s) END
  129. END CheckSym;
  130.  
  131. (*------------------------------------*)
  132. PROCEDURE CheckNonStandard ();
  133. BEGIN (* CheckNonStandard *)
  134.   IF OCS.option [OCS.standard] THEN OCS.Mark (915) END
  135. END CheckNonStandard;
  136.  
  137. (*------------------------------------*)
  138. PROCEDURE SysFlag ( VAR flag : INTEGER );
  139. BEGIN (* SysFlag *)
  140.   (* sym = lbrak *)
  141.   OCS.Get (sym); flag := defaultFlag;
  142.   IF (sym = number) & (OCS.numtyp = 2) THEN
  143.     IF (OCS.intval < 0) OR (OCS.intval > AsmFlag) THEN OCS.Mark (353)
  144.     ELSE flag := SHORT (OCS.intval)
  145.     END;
  146.     OCS.Get (sym)
  147.   ELSE
  148.     OCS.Mark (17); WHILE (sym # rbrak) & (sym # eof) DO OCS.Get (sym) END
  149.   END;
  150.   CheckSym (rbrak); CheckNonStandard ()
  151. END SysFlag;
  152.  
  153. (*------------------------------------*)
  154. PROCEDURE qualident (VAR x : OCT.Item; allocDesc : BOOLEAN);
  155.  
  156.   VAR mnolev : INTEGER; obj : OCT.Object; desc : OCT.Desc; b : BOOLEAN;
  157.  
  158. BEGIN (* qualident *)
  159.   (* sym = ident *)
  160.   OCT.Find (obj, mnolev); IF obj = NIL THEN OCS.Mark (0) END; OCS.Get (sym);
  161.   IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN
  162.     OCS.Get (sym); mnolev := SHORT (-obj.a0);
  163.     IF sym = ident THEN
  164.       OCT.FindImport (obj, obj); IF obj = NIL THEN OCS.Mark (0) END;
  165.       OCS.Get (sym)
  166.     ELSE
  167.       OCS.Mark (10); obj := NIL
  168.     END;
  169.   END;
  170.   x.lev := mnolev; x.obj := obj;
  171.   IF obj # NIL THEN
  172.     x.mode := obj.mode; x.typ := obj.typ; x.a0 := obj.a0;
  173.     x.a1 := obj.a1; x.a2 := obj.a2; x.label := obj.label;
  174.     x.rdOnly := (mnolev < 0) & (obj.visible = OCT.RdOnly);
  175.     IF
  176.       allocDesc & (x.mode IN {Var, Ind}) & (x.typ # NIL)
  177.       & (x.typ.form = DynArr)
  178.     THEN
  179.       NEW (desc); desc.mode := Var; desc.lev := x.lev;
  180.       desc.a0 := x.a0; desc.a1 := 0; desc.a2 := 0; x.desc := desc
  181.     ELSE
  182.       x.desc := NIL
  183.     END
  184.   ELSE
  185.     x.mode := Var; x.typ := OCT.undftyp; x.a0 := 0; x.obj := NIL;
  186.     x.rdOnly := FALSE; x.desc := NIL
  187.   END
  188. END qualident;
  189.  
  190. (*------------------------------------*)
  191. PROCEDURE ConstExpression (VAR x : OCT.Item);
  192.  
  193.   CONST ConstTypes = {Undef .. NilTyp, AdrTyp, BPtrTyp, Pointer};
  194.  
  195. BEGIN (* ConstExpression *)
  196.   Expression (x);
  197.   IF
  198.     (x.mode # Con)
  199.     OR ((x.typ.form = Pointer) & (x.typ.sysflg = OberonFlag))
  200.     OR ~(x.typ.form IN ConstTypes)
  201.   THEN
  202.     OCS.Mark (50); x.mode := Con; x.typ := OCT.inttyp; x.a0 := 1;
  203.   END;
  204. END ConstExpression;
  205.  
  206. (*------------------------------------*)
  207. PROCEDURE NewStr (form : INTEGER) : OCT.Struct;
  208.  
  209.   VAR typ : OCT.Struct;
  210.  
  211. BEGIN (* NewStr *)
  212.   NEW (typ);
  213.   typ.form := form; typ.mno := 0; typ.size := 4; typ.ref := 0;
  214.   typ.BaseTyp := OCT.undftyp; typ.strobj := NIL; typ.link := NIL;
  215.   IF (form = Record) OR (form = Pointer) THEN typ.sysflg := defaultFlag
  216.   ELSE typ.sysflg := OberonFlag
  217.   END;
  218.   RETURN typ
  219. END NewStr;
  220.  
  221. (*------------------------------------*)
  222. PROCEDURE HasTaggedPtr ( typ : OCT.Struct ) : BOOLEAN;
  223.  
  224.   VAR fld : OCT.Object;
  225.  
  226. BEGIN (* HasTaggedPtr *)
  227.   IF typ.sysflg = OberonFlag THEN
  228.     IF typ.form = Pointer THEN RETURN TRUE
  229.     ELSIF typ.form = Array THEN RETURN (HasTaggedPtr (typ.BaseTyp))
  230.     ELSIF typ.form = Record THEN
  231.       IF (typ.BaseTyp # NIL) & HasTaggedPtr (typ.BaseTyp) THEN
  232.         RETURN TRUE
  233.       END;
  234.       fld := typ.link;
  235.       WHILE fld # NIL DO
  236.         IF (fld.mode = Fld) & ((fld.name < 0) OR HasTaggedPtr (fld.typ))
  237.         THEN
  238.           RETURN TRUE
  239.         END;
  240.         fld := fld.left
  241.       END
  242.     END
  243.   END;
  244.   RETURN FALSE
  245. END HasTaggedPtr;
  246.  
  247. (*------------------------------------*)
  248. PROCEDURE CheckMark (VAR mk : SHORTINT; readOnly : BOOLEAN);
  249.  
  250. BEGIN (* CheckMark *)
  251.   OCS.Get (sym);
  252.   IF sym = times THEN
  253.     IF OCC.level = 0 THEN mk := OCT.Exp
  254.     ELSE mk := OCT.NotExp; OCS.Mark (46)
  255.     END;
  256.     OCS.Get (sym)
  257.   ELSIF sym = minus THEN
  258.     IF (OCC.level = 0) & readOnly THEN mk := OCT.RdOnly
  259.     ELSE mk := OCT.NotExp; OCS.Mark (47)
  260.     END;
  261.     OCS.Get (sym)
  262.   ELSE
  263.     mk := OCT.NotExp
  264.   END
  265. END CheckMark;
  266.  
  267. (*------------------------------------*)
  268. PROCEDURE CheckUndefPointerTypes ();
  269.  
  270.   (*------------------------------------*)
  271.   PROCEDURE CheckObj (obj : OCT.Object);
  272.  
  273.   BEGIN (* CheckObj *)
  274.     IF obj # NIL THEN
  275.       IF obj.mode = Undef THEN OCS.Mark (48) END;
  276.       CheckObj (obj.left); CheckObj (obj.right)
  277.     END
  278.   END CheckObj;
  279.  
  280. BEGIN (* CheckUndefPointerTypes *)
  281.   CheckObj (OCT.topScope.link)
  282. END CheckUndefPointerTypes;
  283.  
  284. (*------------------------------------*)
  285. PROCEDURE CheckForwardProcs ();
  286.  
  287.   (*------------------------------------*)
  288.   PROCEDURE CheckObj ( obj : OCT.Object );
  289.  
  290.     (*------------------------------------*)
  291.     PROCEDURE CheckTyp ( typ : OCT.Struct );
  292.       VAR fld : OCT.Object;
  293.     BEGIN (* CheckTyp *)
  294.       IF (typ # NIL) & (typ.form = Record) & (typ.sysflg = OberonFlag) THEN
  295.         fld := typ.link;
  296.         WHILE fld # NIL DO
  297.           IF (fld.mode = TProc) & fld.fwd THEN OCS.Mark (129) END;
  298.           fld := fld.left
  299.         END
  300.       END
  301.     END CheckTyp;
  302.  
  303.   BEGIN (* CheckObj *)
  304.     IF obj # NIL THEN
  305.       IF obj.mode IN {XProc, LProc} THEN
  306.         IF obj.a2 < 0 THEN OCS.Mark (129) END
  307.       ELSIF obj.mode = Typ THEN
  308.         CheckTyp (obj.typ)
  309.       END;
  310.       CheckObj (obj.left); CheckObj (obj.right)
  311.     END
  312.   END CheckObj;
  313.  
  314. BEGIN (* CheckForwardProcs *)
  315.   CheckObj (OCT.topScope.link)
  316. END CheckForwardProcs;
  317.  
  318. (*------------------------------------*)
  319. PROCEDURE RecordType (VAR typ : OCT.Struct);
  320.  
  321.   VAR
  322.     adr, size : LONGINT;
  323.     fld, fld0, fld1, fld2 : OCT.Object;
  324.     ftyp : OCT.Struct;
  325.     base : OCT.Item;
  326.  
  327. BEGIN (* RecordType *)
  328.   typ := NewStr (Record); typ.BaseTyp := NIL; typ.n := 0; adr := 0;
  329.   IF sym = lbrak THEN SysFlag (typ.sysflg) END;
  330.   IF sym = lparen THEN
  331.     OCS.Get (sym); (* record extension *)
  332.     IF sym = ident THEN
  333.       qualident (base, FALSE);
  334.       IF (base.mode = Typ) & (base.typ.form = Record) THEN
  335.         typ.BaseTyp := base.typ; typ.n := base.typ.n + 1;
  336.         IF (typ.sysflg = OberonFlag) & (typ.n > OCM.ExtendLimit)  THEN
  337.           OCS.Mark (236)
  338.         END;
  339.         adr := base.typ.size
  340.       ELSE OCS.Mark (52)
  341.       END
  342.     ELSE OCS.Mark (10)
  343.     END;
  344.     CheckSym (rparen);
  345.     IF OCT.Tagged (typ) # OCT.Tagged (base.typ) THEN OCS.Mark (354) END
  346.   END;
  347.   OCT.OpenScope (0); fld := NIL; NEW (fld1); fld2 := NIL;
  348.   LOOP
  349.     IF sym = ident THEN
  350.       LOOP
  351.         IF sym = ident THEN
  352.           IF typ.BaseTyp # NIL THEN
  353.             OCT.FindField (typ.BaseTyp, fld0);
  354.             IF fld0 # NIL THEN OCS.Mark (1) END
  355.           END;
  356.           OCT.Insert (OCS.name, fld, Fld); CheckMark (fld.visible, TRUE);
  357.           IF (fld # fld2) & (fld.link = NIL) THEN
  358.             IF fld2 = NIL THEN fld1.link := fld; OCT.topScope.right := fld
  359.             ELSE fld2.link := fld
  360.             END;
  361.             fld2 := fld
  362.           END
  363.         ELSE OCS.Mark (10)
  364.         END;
  365.         IF sym = comma THEN OCS.Get (sym)
  366.         ELSIF sym = ident THEN OCS.Mark (19)
  367.         ELSE EXIT
  368.         END
  369.       END; (* LOOP *)
  370.       CheckSym (colon); Type (ftyp, FALSE);
  371.       IF (typ.sysflg # OberonFlag) & HasTaggedPtr (ftyp) THEN
  372.         OCS.Mark (355)
  373.       END;
  374.       size := ftyp.size;
  375.       IF size > 1 THEN
  376.         INC (adr, adr MOD 2); INC (size, size MOD 2) (* word align *)
  377.       END;
  378.       WHILE fld1.link # NIL DO
  379.         fld1 := fld1.link; fld1.typ := ftyp;
  380.         fld1.a0 := adr;
  381.         IF (OCM.MaxTypeSize - size) < adr THEN OCS.Mark (209)
  382.         ELSE INC (adr, size)
  383.         END
  384.       END
  385.     END; (* IF *)
  386.     IF sym = semicolon THEN OCS.Get (sym)
  387.     ELSIF sym = ident THEN OCS.Mark (38)
  388.     ELSE EXIT
  389.     END;
  390.   END; (* LOOP *)
  391.   typ.size := adr + (adr MOD 2); typ.link := OCT.topScope.right;
  392.   CheckUndefPointerTypes ();
  393.   fld0 := OCT.topScope.right;
  394.   WHILE fld0 # NIL DO
  395.     fld1 := fld0.link; fld0.link := NIL;
  396.     fld0.left := fld1; fld0.right := NIL;
  397.     fld0 := fld1
  398.   END;
  399.   OCT.CloseScope ();
  400.   IF typ.sysflg = OberonFlag THEN OCC.AllocTypDesc (typ) END
  401. END RecordType;
  402.  
  403. (*------------------------------------*)
  404. PROCEDURE ArrayType (VAR typ : OCT.Struct; dynArr : BOOLEAN);
  405.  
  406.   VAR x : OCT.Item; f : INTEGER; n : LONGINT;
  407.  
  408. BEGIN (* ArrayType *)
  409.   IF sym # of THEN
  410.     typ := NewStr (Array); ConstExpression (x); f := x.typ.form;
  411.     IF f IN intSet THEN
  412.       IF (x.a0 > 0) & (x.a0 <= OCM.MaxTypeSize) THEN n := x.a0
  413.       ELSE n := 1; OCS.Mark (68)
  414.       END
  415.     ELSE
  416.       OCS.Mark (51); n := 1
  417.     END;
  418.     IF sym = of THEN OCS.Get (sym); Type (typ.BaseTyp, FALSE)
  419.     ELSIF sym = comma THEN OCS.Get (sym); ArrayType (typ.BaseTyp, FALSE)
  420.     ELSE OCS.Mark (34)
  421.     END;
  422.     IF (OCM.MaxTypeSize DIV typ.BaseTyp.size) < n THEN
  423.       OCS.Mark (68); n := 1
  424.     END;
  425.     typ.n := n;
  426.     typ.size := n * typ.BaseTyp.size;
  427.     INC (typ.size, typ.size MOD 2); (* keep word alignment *)
  428.   ELSE
  429.     typ := NewStr (DynArr); OCS.Get (sym); Type (typ.BaseTyp, TRUE);
  430.     IF typ.BaseTyp.form = DynArr THEN
  431.       typ.size := typ.BaseTyp.size + 4; typ.adr := typ.BaseTyp.adr + 4
  432.     ELSE
  433.       typ.size := 8; typ.adr := 4
  434.     END
  435.   END;
  436.   IF (typ.form = DynArr) & ~dynArr THEN
  437.     typ := OCT.undftyp; OCS.Mark (325)
  438.   END
  439. END ArrayType;
  440.  
  441. (*------------------------------------*)
  442. (*
  443.   $  FormalParameters  =  "(" [FPSection {";" FPSection}] ")"
  444.   $    [":" qualident].
  445.   $  FPSection  =  [VAR] ident [RegSpec] {"," ident [RegSpec]}
  446.   $    ":" Type.
  447.   $  RegSpec = "{" ConstExpression "}" [".."].
  448. *)
  449. PROCEDURE FormalParameters (
  450.   VAR resTyp : OCT.Struct; VAR psize : LONGINT; sysflg : INTEGER);
  451.  
  452.   CONST
  453.     D0 = 0; A5 = 13;
  454.  
  455.   VAR
  456.     mode : SHORTINT; gotUpto, regPars : BOOLEAN;
  457.     adr, size : LONGINT; res, reg : OCT.Item;
  458.     par, par1, par2: OCT.Object; typ : OCT.Struct;
  459.     close : INTEGER;
  460.  
  461. BEGIN (* FormalParameters *)
  462.   adr := 0; gotUpto := FALSE; regPars := (sysflg = AsmFlag);
  463.   (* Make allowance for the receiver of type-bound and libcall procedures *)
  464.   IF OCT.topScope.right # NIL THEN
  465.     par1 := OCT.topScope.right; adr := par1.a0
  466.   ELSE
  467.     NEW (par1)
  468.   END;
  469.   par2 := par1;
  470.   IF (sym = ident) OR (sym = var) THEN
  471.     LOOP
  472.       IF sym = var THEN OCS.Get (sym); mode := Ind
  473.       ELSE mode := Var
  474.       END;
  475.       LOOP
  476.         IF sym = ident THEN
  477.           OCT.Insert (OCS.name, par, mode); OCS.Get (sym);
  478.           IF OCT.topScope.right = NIL THEN OCT.topScope.right := par END;
  479.           IF (par # par2) & (par.link = NIL) THEN
  480.             par2.link := par;
  481.             IF par1.link = NIL THEN par1.link := par END;
  482.           END;
  483.           par2 := par
  484.         ELSE OCS.Mark (10)
  485.         END;
  486.  
  487.         IF (sym = lbrak) OR (sym = lbrace) THEN (* Register specification *)
  488.           IF sym = lbrak THEN close := rbrak ELSE close := rbrace END;
  489.           OCS.Get (sym); ConstExpression (reg);
  490.           IF reg.typ.form IN intSet THEN
  491.             IF (reg.a0 >= D0) & (reg.a0 <= A5) THEN par.a0 := reg.a0;
  492.             ELSE OCS.Mark (903)
  493.             END
  494.           ELSE OCS.Mark (902)
  495.           END;
  496.           CheckSym (close);
  497.           IF ~regPars THEN OCS.Mark (901); par.mode := Var; par.a0 := 0 END
  498.         ELSIF regPars THEN OCS.Mark (340)
  499.         END;
  500.  
  501.         IF sym = upto THEN
  502.           IF (mode = Var) & (sysflg IN {CFlag, AsmFlag}) THEN
  503.             par.mode := VarArg
  504.           ELSE
  505.             OCS.Mark (336)
  506.           END;
  507.           gotUpto := TRUE; OCS.Get (sym)
  508.         END;
  509.  
  510.         IF sym = comma THEN OCS.Get (sym)
  511.         ELSIF sym = ident THEN OCS.Mark (19)
  512.         ELSIF sym = var THEN OCS.Mark (19); OCS.Get (sym)
  513.         ELSE EXIT
  514.         END;
  515.       END; (* LOOP *)
  516.       CheckSym (colon); Type (typ, TRUE);
  517.       IF (sysflg # OberonFlag) & OCT.Tagged (typ) THEN OCS.Mark (356) END;
  518.     (*IF (mode = VarArg) & (typ.size > PtrSize) THEN OCS.Mark (338) END;*)
  519.  
  520.       IF sysflg = OberonFlag THEN
  521.         IF mode = Ind  THEN (* VAR param *)
  522.           IF (typ.form = Record) & (typ.sysflg = OberonFlag) THEN
  523.             size := RecDescSize
  524.           ELSIF typ.form = DynArr THEN
  525.             size := typ.size
  526.           ELSE
  527.             size := AdrSize
  528.           END
  529.         ELSE
  530.           size := typ.size; IF ODD (size) THEN INC (size) END;
  531.         END;
  532.         WHILE par1.link # NIL DO
  533.           par1 := par1.link; par1.typ := typ;
  534.           DEC (adr, size); par1.a0 := adr;
  535.         END;
  536.       ELSE
  537.         WHILE par1.link # NIL DO par1 := par1.link; par1.typ := typ END
  538.       END;
  539.       IF sym = semicolon THEN OCS.Get (sym)
  540.       ELSIF sym = ident THEN OCS.Mark (38)
  541.       ELSE EXIT
  542.       END;
  543.       IF gotUpto THEN OCS.Mark (337) END
  544.     END; (* LOOP *)
  545.   END; (* IF *)
  546.  
  547.   IF sysflg = OberonFlag THEN
  548.     psize := psize - adr;
  549.     IF psize > OCM.ParLimit THEN OCS.Mark (209); psize := 0 END;
  550.     par := OCT.topScope.right;
  551.     WHILE par # NIL DO INC (par.a0, psize); par := par.link END;
  552.   END;
  553.  
  554.   CheckSym (rparen);
  555.   IF sym = colon THEN
  556.     OCS.Get (sym); resTyp := OCT.undftyp;
  557.     IF sym = ident THEN
  558.       qualident (res, FALSE);
  559.       IF res.mode = Typ THEN
  560.         IF res.typ.form <= ProcTyp THEN resTyp := res.typ
  561.         ELSE OCS.Mark (54)
  562.         END
  563.       ELSE OCS.Mark (52)
  564.       END
  565.     ELSE OCS.Mark (10)
  566.     END;
  567.   ELSE
  568.     resTyp := OCT.notyp
  569.   END;
  570. END FormalParameters;
  571.  
  572. (*------------------------------------*)
  573. PROCEDURE ProcType (VAR typ : OCT.Struct);
  574.  
  575.   VAR psize : LONGINT;
  576.  
  577. BEGIN (* ProcType *)
  578.   typ := NewStr (ProcTyp); typ.size := ProcSize;
  579.   IF sym = lparen THEN
  580.     OCS.Get (sym); OCT.OpenScope (OCC.level); psize := ParOrg;
  581.     FormalParameters (typ.BaseTyp, psize, OberonFlag);
  582.     typ.link := OCT.topScope.right; OCT.CloseScope ();
  583.   ELSE
  584.     typ.BaseTyp := OCT.notyp; typ.link := NIL
  585.   END;
  586. END ProcType;
  587.  
  588. (*------------------------------------*)
  589. PROCEDURE SetPtrBase (ptyp, btyp : OCT.Struct);
  590.  
  591. BEGIN (* SetPtrBase *)
  592.   IF
  593.     ((btyp.form = Record) & (OCT.Tagged (ptyp) = OCT.Tagged (btyp)))
  594.     OR (btyp.form = Array)
  595.   THEN
  596.     ptyp.BaseTyp := btyp; ptyp.label := OCT.PointerDesc
  597.   ELSIF (btyp.form = DynArr) & (ptyp.sysflg = OberonFlag) THEN
  598.     ptyp.BaseTyp := btyp; ptyp.size := btyp.size;
  599.     OCC.AllocTypDesc (ptyp)
  600.   ELSE
  601.     ptyp.BaseTyp := OCT.undftyp; OCS.Mark (57)
  602.   END
  603. END SetPtrBase;
  604.  
  605. (*------------------------------------*)
  606. (*
  607.   $  type  =  qualident | ArrayType | RecordType | StructType| PointerType |
  608.   $    ProcedureType.
  609. *)
  610. PROCEDURE Type (VAR typ : OCT.Struct; dynArr : BOOLEAN);
  611.  
  612.   VAR lev : INTEGER; obj : OCT.Object; x : OCT.Item;
  613.  
  614. BEGIN (* Type *)
  615.   typ := OCT.undftyp;
  616.   IF sym < lparen THEN
  617.     OCS.Mark (12); REPEAT OCS.Get (sym) UNTIL sym >= lparen
  618.   END;
  619.   IF sym = ident THEN
  620.     qualident (x, FALSE);
  621.     IF x.mode = Typ THEN
  622.       typ := x.typ; IF typ = OCT.notyp THEN OCS.Mark (58) END
  623.     ELSE
  624.       OCS.Mark (52)
  625.     END
  626.   ELSIF sym = array THEN
  627.     OCS.Get (sym); ArrayType (typ, TRUE)
  628.   ELSIF sym = record THEN
  629.     OCS.Get (sym); RecordType (typ); CheckSym (end)
  630.   ELSIF (sym = pointer) THEN
  631.     typ := NewStr (Pointer); typ.link := NIL; typ.size := PtrSize;
  632.     OCS.Get (sym); IF sym = lbrak THEN SysFlag (typ.sysflg) END;
  633.     CheckSym (to);
  634.     IF sym = ident THEN
  635.       OCT.Find (obj, lev);
  636.       IF obj = NIL THEN (* forward reference *)
  637.         OCT.Insert (OCS.name, obj, Undef); typ.BaseTyp := OCT.undftyp;
  638.         obj.typ := typ; OCS.Get (sym)
  639.       ELSE
  640.         qualident (x, FALSE);
  641.         IF x.mode = Typ THEN SetPtrBase (typ, x.typ)
  642.         ELSE typ.BaseTyp := OCT.undftyp; OCS.Mark (52)
  643.         END
  644.       END
  645.     ELSE Type (x.typ, TRUE); SetPtrBase (typ, x.typ)
  646.     END
  647.   ELSIF sym = procedure THEN
  648.     OCS.Get (sym); ProcType (typ)
  649.   ELSE
  650.     OCS.Mark (12)
  651.   END;
  652.   IF (typ.form = DynArr) & ~dynArr THEN
  653.     typ := OCT.undftyp; OCS.Mark (325)
  654.   END;
  655.   IF (sym # semicolon) & (sym # rparen) & (sym # end) THEN
  656.     OCS.Mark (15);
  657.     WHILE (sym < ident) OR (else < sym) & (sym < begin) DO
  658.       OCS.Get (sym)
  659.     END
  660.   END
  661. END Type;
  662.  
  663. (*------------------------------------*)
  664. (*
  665.   $  designator  =  qualident
  666.   $    {"." ident | "[" ExpList "]" | "(" qualident ")" | "^" }.
  667.        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
  668.   $  ExpList  =  expression {"," expression}.
  669. *)
  670. PROCEDURE selector (VAR x, rcvr : OCT.Item);
  671.  
  672.   VAR fld : OCT.Object; y : OCT.Item; t : OCT.Struct; f : INTEGER;
  673.  
  674. BEGIN (* selector *)
  675.   IF x.mode = LibCall THEN
  676.     rcvr.mode := Var; rcvr.lev := x.lev; rcvr.a0 := x.a1; rcvr.a1 := 0;
  677.     rcvr.a2 := 0; rcvr.typ := OCT.lwordtyp; rcvr.rdOnly := TRUE
  678.   ELSE rcvr.mode := Undef
  679.   END;
  680.   LOOP
  681.     IF sym = lbrak THEN
  682.       OCS.Get (sym);
  683.       LOOP
  684.         IF (x.typ # NIL) & (x.typ.form = Pointer) THEN
  685.           OCE.DeRef (x, TRUE)
  686.         END;
  687.         Expression (y); OCE.Index (x, y);
  688.         IF sym = comma THEN OCS.Get (sym) ELSE EXIT END
  689.       END;
  690.       CheckSym (rbrak)
  691.     ELSIF sym = period THEN
  692.       OCS.Get (sym);
  693.       IF sym = ident THEN
  694.         IF x.typ # NIL THEN
  695.           t := x.typ; f := t.form; IF f = Pointer THEN t := t.BaseTyp END;
  696.           IF (t.form = Record) THEN
  697.             OCT.FindField (t, fld);
  698.             IF fld # NIL THEN
  699.               IF fld.mode = Fld THEN
  700.                 IF f = Pointer THEN OCE.DeRef (x, TRUE) END;
  701.                 OCE.Field (x, fld)
  702.               ELSIF fld.mode = TProc THEN
  703.                 rcvr := x; x.mode := TProc; x.a0 := fld.a0; x.a2 := 0;
  704.                 x.obj := fld; x.typ := fld.typ; x.label := fld.label
  705.               END
  706.             ELSE
  707.               OCS.Mark (83); x.typ := OCT.undftyp; x.mode := Var;
  708.               x.rdOnly := FALSE
  709.             END
  710.           ELSE OCS.Mark (53)
  711.           END;
  712.         ELSE OCS.Mark (52) (* ? *)
  713.         END;
  714.         OCS.Get (sym)
  715.       ELSE OCS.Mark (10)
  716.       END;
  717.     ELSIF sym = arrow THEN
  718.       IF x.mode = TProc THEN
  719.         IF (rcvr.mode IN {Var,Ind}) & (rcvr.a2 < 0) THEN
  720.           OCT.SuperCall (x.obj.name, rcvr.typ, fld);
  721.           IF fld # NIL THEN
  722.             x.a2 := -1; x.obj := fld; x.label := fld.label
  723.           ELSE OCS.Mark (333)
  724.           END
  725.         ELSE OCS.Mark (332)
  726.         END;
  727.         OCS.Get (sym)
  728.       ELSE
  729.         OCS.Get (sym); OCE.DeRef (x, FALSE)
  730.       END
  731.     ELSIF (sym = lparen) & (x.mode < Typ) & (x.typ.form # ProcTyp) THEN
  732.       OCS.Get (sym);
  733.       IF sym = ident THEN
  734.         qualident (y, FALSE);
  735.         IF y.mode = Typ THEN OCE.TypTest (x, y, FALSE)
  736.         ELSE OCS.Mark (52)
  737.         END
  738.       ELSE
  739.         OCS.Mark (10)
  740.       END;
  741.       CheckSym (rparen)
  742.     ELSE
  743.       EXIT
  744.     END;
  745.   END; (* LOOP *)
  746. END selector;
  747.  
  748. (*------------------------------------*)
  749. PROCEDURE IsParam (obj : OCT.Object) : BOOLEAN;
  750.  
  751. BEGIN (* IsParam *)
  752.   RETURN (obj # NIL) & (obj.mode <= Ind) & (obj.a0 >= 0)
  753. END IsParam;
  754.  
  755. (*------------------------------------*)
  756. PROCEDURE VarArgs
  757.   ( VAR apar : OCT.Item; fpar : OCT.Object;
  758.     VAR stackload : LONGINT; load : BOOLEAN );
  759.  
  760.   VAR x : OCT.Item;
  761.  
  762. BEGIN (* VarArgs *)
  763.   IF sym = comma THEN
  764.     OCS.Get (sym); Expression (x); VarArgs (x, fpar, stackload, FALSE)
  765.   END;
  766.   OCH.VarArgParam (apar, fpar, load); INC (stackload, fpar.typ.size)
  767. END VarArgs;
  768.  
  769. (*------------------------------------*)
  770. PROCEDURE ReverseParam
  771.   ( VAR apar      : OCT.Item;
  772.     VAR fpar      : OCT.Object;
  773.     VAR stackload : LONGINT );
  774.  
  775.   VAR x : OCT.Item; next : OCT.Object;
  776.  
  777. BEGIN (* ReverseParam *)
  778.   IF IsParam (fpar) THEN
  779.     next := fpar.link;
  780.     IF sym = comma THEN
  781.       OCS.Get (sym); Expression (x);
  782.       IF fpar.mode = VarArg THEN VarArgs (x, fpar, stackload, FALSE)
  783.       ELSE ReverseParam (x, next, stackload)
  784.       END;
  785.     END;
  786.     OCH.Param (apar, fpar, CProc); INC (stackload, fpar.typ.size);
  787.     fpar := next
  788.   ELSE
  789.     OCS.Mark (64)
  790.   END
  791. END ReverseParam;
  792.  
  793. (*------------------------------------*)
  794. (*
  795.   $  ActualParameters  =  "(" [ExpList] ")" .
  796.   $  ExpList  =  expression {"," expression}.
  797. *)
  798.  
  799. PROCEDURE ActualParameters
  800.   ( fpar          : OCT.Object;
  801.     mode          : INTEGER;
  802.     VAR stackload : LONGINT );
  803.  
  804.   VAR apar : OCT.Item; R : OCC.RegState;
  805.  
  806. BEGIN (* ActualParameters *)
  807.   IF sym # rparen THEN
  808.     R := OCC.regState;
  809.     IF mode = CProc THEN
  810.       Expression (apar); ReverseParam (apar, fpar, stackload)
  811.     ELSE
  812.       LOOP
  813.         Expression (apar);
  814.         IF IsParam (fpar) THEN
  815.           IF fpar.mode = VarArg THEN VarArgs (apar, fpar, stackload, TRUE)
  816.           ELSE OCH.Param (apar, fpar, mode)
  817.           END;
  818.           fpar := fpar.link
  819.         ELSE
  820.           OCS.Mark (64)
  821.         END;
  822.         IF sym = comma THEN OCS.Get (sym)
  823.         ELSIF (lparen <= sym) & (sym <= ident) THEN OCS.Mark (19)
  824.         ELSE EXIT
  825.         END
  826.       END;
  827.     END; (* IF *)
  828.     OCC.FreeRegs (R);
  829.   END;
  830.   IF IsParam (fpar) THEN OCS.Mark (65) END
  831. END ActualParameters;
  832.  
  833. (*------------------------------------*)
  834. PROCEDURE StandProcCall (VAR x : OCT.Item);
  835.  
  836.   VAR y, z : OCT.Item; m, n : INTEGER; R : OCC.RegState;
  837.  
  838. BEGIN (* StandProcCall *)
  839.   m := SHORT (x.a0); n := 0; R.regs := {};
  840.   (* IF m = OCT.pASSERT THEN OCC.genCode := OCS.pragma [OCS.assertChk] END; *)
  841.   OCP.SaveRegs (m, R);
  842.   IF (sym = lparen) THEN
  843.     OCS.Get (sym);
  844.     IF sym # rparen THEN
  845.       LOOP
  846.         IF m = OCT.pINLINE THEN
  847.           Expression (x); OCP.Inline (x);
  848.         ELSIF n = 0 THEN
  849.           Expression (x); OCP.StPar1 (x, m, R); n := 1
  850.         ELSIF m = OCT.pNEW THEN
  851.           IF n = 1 THEN y.mode := Undef END;
  852.           Expression (z); OCP.NewPar (x, y, z, n); INC (n)
  853.         ELSIF n = 1 THEN
  854.           Expression (y); OCP.StPar2 (x, y, m, R); n := 2;
  855.         ELSIF n = 2 THEN
  856.           Expression (y); OCP.StPar3 (x, y, m, R); n := 3;
  857.         ELSE
  858.           OCS.Mark (64); Expression (y);
  859.         END;
  860.         IF sym = comma THEN
  861.           OCS.Get (sym)
  862.         ELSIF (lparen <= sym) & (sym <= ident) THEN
  863.           OCS.Mark (19)
  864.         ELSE
  865.           EXIT
  866.         END;
  867.       END; (* LOOP *)
  868.       CheckSym (rparen)
  869.     ELSE
  870.       OCS.Get (sym)
  871.     END;
  872.     OCP.StFct (x, m, n, R);
  873.   ELSE
  874.     OCS.Mark (29)
  875.   END;
  876.   (* OCC.genCode := TRUE *)
  877. END StandProcCall;
  878.  
  879. (*------------------------------------*)
  880. (*
  881.   $  element  =  expression [".." expression].
  882. *)
  883. PROCEDURE Element (VAR x : OCT.Item);
  884.  
  885.   VAR e1, e2 : OCT.Item;
  886.  
  887. BEGIN (* Element *)
  888.   Expression (e1);
  889.   IF sym = upto THEN
  890.     OCS.Get (sym); Expression (e2); OCE.Set1 (x, e1, e2)
  891.   ELSE
  892.     OCE.Set0 (x, e1)
  893.   END;
  894. END Element;
  895.  
  896. (*------------------------------------*)
  897. (*
  898.   $  set  =  "{" [element {"," element}] "}".
  899. *)
  900. PROCEDURE Sets (VAR x : OCT.Item);
  901.  
  902.   VAR y : OCT.Item;
  903.  
  904. BEGIN (* Sets *)
  905.   x.typ := OCT.settyp; y.typ := OCT.settyp;
  906.   IF sym # rbrace THEN
  907.     Element (x);
  908.     LOOP
  909.       IF sym = comma THEN
  910.         OCS.Get (sym)
  911.       ELSIF (lparen <= sym) & (sym <= ident) THEN
  912.         OCS.Mark (19)
  913.       ELSE
  914.         EXIT
  915.       END;
  916.       Element (y); OCE.Op (plus, x, y, TRUE) (* x := x + y *)
  917.     END; (* LOOP *)
  918.   ELSE
  919.     x.mode := Con; x.a0 := 0
  920.   END;
  921.   CheckSym (rbrace);
  922. END Sets;
  923.  
  924. (*------------------------------------*)
  925. (*
  926.   $  factor  =  number | CharConstant | string | NIL | set |
  927.   $    designator [ActualParameters] | "(" expression ")" | "~" factor.
  928. *)
  929. PROCEDURE Factor (VAR x : OCT.Item);
  930.  
  931.   VAR
  932.     fpar : OCT.Object; rcvr : OCT.Item; R : OCC.RegState; mask : SET;
  933.     stackload : LONGINT;
  934.  
  935. BEGIN (* Factor *)
  936.   IF sym < lparen THEN
  937.     OCS.Mark (13);
  938.     REPEAT OCS.Get (sym) UNTIL sym >= lparen
  939.   END;
  940.   x.desc := NIL;
  941.   IF sym = ident THEN
  942.     qualident (x, TRUE); selector (x, rcvr);
  943.     IF x.mode = SProc THEN
  944.       StandProcCall (x)
  945.     ELSIF sym = lparen THEN
  946.       OCH.PrepCall (x, fpar, mask);
  947.       IF x.mode IN {TProc, LibCall} THEN
  948.         OCC.SaveRegisters (R, rcvr, mask);
  949.         IF x.mode = TProc THEN
  950.           OCH.Receiver (TProc, rcvr, x.obj.link, mask)
  951.         ELSE
  952.           OCH.Receiver (LibCall, rcvr, NIL, mask)
  953.         END
  954.       ELSE
  955.         OCC.SaveRegisters (R, x, mask);
  956.       END;
  957.       OCS.Get (sym); stackload := 0;
  958.       ActualParameters (fpar, x.mode, stackload);
  959.       OCH.Call (x, rcvr, stackload, mask);
  960.       IF x.mode # LibCall THEN OCC.ForgetRegs END;
  961.       OCC.RestoreRegisters (R, x);
  962.       CheckSym (rparen)
  963.     END;
  964.   ELSIF sym = number THEN
  965.     OCS.Get (sym); x.mode := Con;
  966.     CASE OCS.numtyp OF
  967.       1 : x.typ := OCT.chartyp; x.a0 := OCS.intval
  968.       |
  969.       2 : x.a0 := OCS.intval; OCE.SetIntType (x)
  970.       |
  971.       3 : x.typ := OCT.realtyp; OCE.AssReal (x, OCS.realval)
  972.       |
  973.       4 : x.typ := OCT.lrltyp; OCE.AssLReal (x, OCS.lrlval)
  974.       |
  975.     END; (* CASE OCS.numtyp *)
  976.   ELSIF sym = string THEN
  977.     x.typ := OCT.stringtyp; x.mode := Con;
  978.     OCC.AllocString (OCS.name, OCS.intval, x); OCS.Get (sym);
  979.     IF ~OCS.option [OCS.standard] THEN
  980.       WHILE sym = string DO
  981.         OCC.ConcatString (OCS.name, OCS.intval, x); OCS.Get (sym)
  982.       END
  983.     END
  984.   ELSIF sym = nil THEN
  985.     OCS.Get (sym); x.typ := OCT.niltyp; x.mode := Con; x.a0 := 0
  986.   ELSIF sym = lparen THEN
  987.     OCS.Get (sym); Expression (x); CheckSym (rparen)
  988.   ELSIF sym = lbrak THEN
  989.     OCS.Get (sym); OCS.Mark (29); Expression (x); CheckSym (rparen)
  990.   ELSIF sym = lbrace THEN
  991.     OCS.Get (sym); Sets (x)
  992.   ELSIF sym = not THEN
  993.     OCS.Get (sym); Factor (x); OCE.MOp (not, x)
  994.   ELSE
  995.     OCS.Mark (13); OCS.Get (sym); x.typ := OCT.undftyp; x.mode := Var;
  996.     x.a0 := 0
  997.   END;
  998. END Factor;
  999.  
  1000. (*------------------------------------*)
  1001. (*
  1002.   $  term  =  factor {MulOperator factor}.
  1003.   $  MulOperator  =  "*" | "/" | DIV | MOD | "&" .
  1004. *)
  1005. PROCEDURE Term (VAR x : OCT.Item);
  1006.  
  1007.   VAR
  1008.     y : OCT.Item; mulop : INTEGER;
  1009.  
  1010. BEGIN (* Term *)
  1011.   Factor (x);
  1012.   WHILE (times <= sym) & (sym <= and) DO
  1013.     mulop := sym; OCS.Get (sym);
  1014.     IF mulop = and THEN OCE.MOp (and, x); END;
  1015.     Factor (y); OCE.Op (mulop, x, y, TRUE);
  1016.     IF mulop = and THEN OCC.ForgetRegs END;
  1017.   END;
  1018. END Term;
  1019.  
  1020. (*------------------------------------*)
  1021. (*
  1022.   $  SimpleExpression  =  ["+"|"-"] term {AddOperator term}.
  1023.   $  AddOperator  =  "+" | "-" | OR .
  1024. *)
  1025. PROCEDURE SimpleExpression (VAR x : OCT.Item);
  1026.  
  1027.   VAR y : OCT.Item; addop : INTEGER;
  1028.  
  1029. BEGIN (* SimpleExpression *)
  1030.   IF sym = minus THEN OCS.Get (sym); Term (x); OCE.MOp (minus, x)
  1031.   ELSIF sym = plus THEN OCS.Get (sym); Term (x); OCE.MOp (plus, x)
  1032.   ELSE Term (x)
  1033.   END;
  1034.   WHILE (plus <= sym) & (sym <= or) DO
  1035.     addop := sym; OCS.Get (sym);
  1036.     IF addop = or THEN OCE.MOp (or, x) END;
  1037.     Term (y); OCE.Op (addop, x, y, TRUE);
  1038.     IF addop = or THEN OCC.ForgetRegs END;
  1039.   END;
  1040. END SimpleExpression;
  1041.  
  1042. (*------------------------------------*)
  1043. (*
  1044.   $  expression  =  SimpleExpression [relation SimpleExpression].
  1045.   $  relation  =  "=" | "#" | "<" | "<=" | ">" | ">=" | IN | IS.
  1046. *)
  1047. PROCEDURE Expression (VAR x : OCT.Item);
  1048.  
  1049.   VAR
  1050.     y : OCT.Item; relation : INTEGER;
  1051.  
  1052. BEGIN (* Expression *)
  1053.   SimpleExpression (x);
  1054.   IF (eql <= sym) & (sym <= geq) THEN
  1055.     relation := sym; OCS.Get (sym);
  1056.     IF x.typ = OCT.booltyp THEN OCE.MOp (relation, x) END;
  1057.     SimpleExpression (y); OCE.Op (relation, x, y, TRUE)
  1058.   ELSIF sym = in THEN
  1059.     OCS.Get (sym); SimpleExpression (y); OCE.In (x, y)
  1060.   ELSIF sym = is THEN
  1061.     IF x.mode >= Typ THEN OCS.Mark (112) END;
  1062.     OCS.Get (sym);
  1063.     IF sym = ident THEN
  1064.       qualident (y, FALSE);
  1065.       IF y.mode = Typ THEN OCE.TypTest (x, y, TRUE) ELSE OCS.Mark (52) END
  1066.     ELSE
  1067.       OCS.Mark (10)
  1068.     END;
  1069.   END;
  1070. END Expression;
  1071.  
  1072. (*------------------------------------*)
  1073. PROCEDURE Receiver (VAR rtyp : OCT.Struct);
  1074.  
  1075.   VAR
  1076.     mode : SHORTINT; mnolev : INTEGER; recvr, obj : OCT.Object;
  1077.     typ : OCT.Struct;
  1078.  
  1079. BEGIN (* Receiver *)
  1080.   recvr := NIL; rtyp := OCT.undftyp;
  1081.   IF sym = var THEN mode := Ind; OCS.Get (sym)
  1082.   ELSE mode := Var
  1083.   END;
  1084.   IF sym = ident THEN
  1085.     OCT.Insert (OCS.name, recvr, mode); OCS.Get (sym);
  1086.     OCT.topScope.right := recvr
  1087.   ELSE
  1088.     NEW (recvr); OCS.Mark (10)
  1089.   END;
  1090.   recvr.typ := OCT.undftyp; recvr.a2 := -1;
  1091.   CheckSym (colon);
  1092.   IF sym = ident THEN
  1093.     OCT.Find (obj, mnolev); IF obj = NIL THEN OCS.Mark (0) END;
  1094.     OCS.Get (sym);
  1095.     IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN
  1096.       OCS.Get (sym);
  1097.       IF sym = ident THEN
  1098.         OCT.FindImport (obj, obj); IF obj = NIL THEN OCS.Mark (0) END;
  1099.         OCS.Get (sym)
  1100.       ELSE
  1101.         OCS.Mark (10); obj := NIL
  1102.       END;
  1103.       OCS.Mark (305)
  1104.     END;
  1105.     IF (obj # NIL) & (obj.mode = Typ) THEN
  1106.       typ := obj.typ;
  1107.       IF typ # NIL THEN
  1108.         IF typ.mno > 0 THEN OCS.Mark (305) END;
  1109.         IF
  1110.           (mode = Ind)
  1111.           & ((typ.form # Record) OR (typ.sysflg # OberonFlag))
  1112.         THEN
  1113.           OCS.Mark (307); typ := OCT.undftyp
  1114.         ELSIF (mode = Var) THEN
  1115.           IF typ.form # Pointer THEN OCS.Mark (306); typ := OCT.undftyp END
  1116.         END;
  1117.       ELSE typ := OCT.undftyp
  1118.       END;
  1119.       IF typ.form = Pointer THEN rtyp := typ.BaseTyp ELSE rtyp := typ END;
  1120.       recvr.typ := typ;
  1121.       IF mode = Var THEN recvr.a0 := -AdrSize
  1122.       ELSE recvr.a0 := -RecDescSize
  1123.       END
  1124.     ELSE OCS.Mark (52)
  1125.     END
  1126.   ELSE OCS.Mark (10)
  1127.   END;
  1128.   CheckSym (rparen);
  1129. END Receiver;
  1130.  
  1131. (*------------------------------------*)
  1132. (*
  1133.   $  ProcedureDeclaration  =  ProcedureHeading ";" ProcedureBody ident.
  1134.   $  ProcedureHeading  =  PROCEDURE ["*"] identdef [FormalParameters].
  1135.   $  ForwardDeclaration  =  PROCEDURE "^" identdef [FormalParameters].
  1136. *)
  1137. PROCEDURE ProcedureDeclaration ();
  1138.  
  1139.   (* CONST pname = "ProcedureDeclaration"; *)
  1140.  
  1141.   VAR
  1142.     proc, proc1, par : OCT.Object;
  1143.     rtyp : OCT.Struct;
  1144.     retList : LONGINT; lvl, sysflg, close : INTEGER; mode : SHORTINT;
  1145.     body, forward : BOOLEAN;
  1146.     psize, dsize : LONGINT;
  1147.     x : OCT.Item;
  1148.     label : OCT.Label;
  1149.  
  1150. BEGIN (* ProcedureDeclaration *)
  1151.   dsize := 0; proc := NIL; body := TRUE; forward := FALSE; mode := LProc;
  1152.   label := NIL; sysflg := defaultFlag;
  1153.  
  1154.   IF sym # ident THEN
  1155.     IF sym = arrow THEN
  1156.       forward := TRUE; body := FALSE; OCS.Get (sym)
  1157.     ELSIF sym = times THEN
  1158.       CheckNonStandard ();
  1159.       IF OCC.level = 0 THEN mode := XProc ELSE OCS.Mark (46) END;
  1160.       OCS.Get (sym)
  1161.     END;
  1162.     IF sym = lbrak THEN SysFlag (sysflg) END;
  1163.   END;
  1164.  
  1165.   IF sysflg # OberonFlag THEN
  1166.     IF mode = XProc THEN OCS.Mark (119)
  1167.     ELSIF forward THEN OCS.Mark (343)
  1168.     END;
  1169.     IF sysflg = M2Flag THEN mode := M2Proc
  1170.     ELSIF sysflg = CFlag THEN mode := CProc
  1171.     ELSIF sysflg = AsmFlag THEN mode := AProc
  1172.     ELSE OCS.Mark (900); mode := M2Proc
  1173.     END;
  1174.     body := FALSE
  1175.   END;
  1176.  
  1177.   IF sym = lparen THEN (* Type-bound procedure *)
  1178.     OCT.OpenScope (OCC.level + 1); OCS.Get (sym); Receiver (rtyp);
  1179.     IF OCC.level > 0 THEN OCS.Mark (46)
  1180.     ELSIF mode = XProc THEN OCS.Mark (119)
  1181.     ELSIF sysflg # OberonFlag THEN OCS.Mark (344)
  1182.     END;
  1183.     mode := TProc
  1184.   ELSIF sym # ident THEN OCS.Mark (10)
  1185.   END;
  1186.  
  1187.   IF sym = ident THEN
  1188.     IF mode = TProc THEN
  1189.       (*
  1190.         We must be aware of three possibilities for type-bound procedures:
  1191.         - There is a forward declaration for the *same* type
  1192.           (proc1.a1 = rtyp.n) & (proc1.fwd = TRUE);
  1193.         - There is a forward declaration for a *base* type
  1194.           (proc1.a1 # rtyp.n) & (proc1.fwd = TRUE);
  1195.         - It is a redefinition of a procedure from a base type
  1196.           (proc1.a1 # rtyp.n) & (proc1.fwd = FALSE).
  1197.       *)
  1198.       OCT.FindField (rtyp, proc1);
  1199.       IF proc1 # NIL THEN
  1200.         IF proc1.mode # TProc THEN (* Name used for a record field *)
  1201.           OCS.Mark (329); proc1 := NIL
  1202.         ELSIF (proc1.a1 = rtyp.n) & (proc1.fwd = FALSE) THEN
  1203.           (* Procedure already declared *)
  1204.           OCS.Mark (1); proc1 := NIL
  1205.         END
  1206.       END;
  1207.       NEW (proc); proc.name := OCT.InsertName (OCS.name);
  1208.       CheckMark (proc.visible, FALSE);
  1209.       (* Assign a procedure number *)
  1210.       IF proc1 # NIL THEN proc.a0 := proc1.a0
  1211.       ELSE proc.a0 := -1
  1212.       END;
  1213.       IF proc.a0 < 0 THEN proc.a2 := 1
  1214.       ELSE proc.a2 := 0
  1215.       END;
  1216.       (* Note the type level *)
  1217.       proc.a1 := rtyp.n;
  1218.       (* Prepare to parse the parameters *)
  1219.       INC (OCC.level);
  1220.       IF (*(proc.visible = OCT.Exp)
  1221.        &*) ~OCS.pragma [OCS.longVars]
  1222.        & ~OCM.SmallData & ~OCM.Resident
  1223.       THEN (* return address + frame ptr + global var base *)
  1224.         psize := XParOrg
  1225.       ELSE (* return address + frame ptr *)
  1226.         psize := ParOrg
  1227.       END
  1228.     ELSE
  1229.       (* See if there is a forward declaration already *)
  1230.       OCT.Find (proc1, lvl); IF lvl # OCC.level THEN proc1 := NIL END;
  1231.       IF (sysflg = OberonFlag) & (proc1 # NIL) & proc1.fwd THEN
  1232.         (* there exists a corresponding forward declaration *)
  1233.         NEW (proc); CheckMark (proc.visible, FALSE);
  1234.         IF proc.visible = OCT.Exp THEN mode := XProc END;
  1235.       ELSE
  1236.         IF proc1 # NIL THEN OCS.Mark (1); proc1 := NIL END;
  1237.         OCT.Insert (OCS.name, proc, mode); CheckMark (proc.visible, FALSE);
  1238.         IF (proc.visible = OCT.Exp) & (mode = LProc) THEN mode := XProc END;
  1239.         IF (mode = LProc) & (OCC.level > 0) THEN
  1240.           proc.a0 := procNo; INC (procNo)
  1241.         ELSE
  1242.           proc.a0 := 0
  1243.         END
  1244.       END;
  1245.  
  1246.       IF (sym = lbrak) OR (sym = lbrace) THEN
  1247.         (* External name or library call *)
  1248.         IF sym = lbrak THEN close := rbrak ELSE close := rbrace END;
  1249.         IF forward THEN OCS.Mark (343); forward := FALSE END;
  1250.         body := FALSE; OCS.Get (sym);
  1251.         IF sym = string THEN (* External name *)
  1252.           IF sysflg = OberonFlag THEN
  1253.             CheckNonStandard(); sysflg := AsmFlag; mode := AProc
  1254.           END;
  1255.           NEW (label, Str.Length (OCS.name) + 1); COPY (OCS.name, label^);
  1256.           OCS.Get (sym)
  1257.         ELSIF sym = ident THEN (* LibCall *)
  1258.           mode := LibCall; sysflg := AsmFlag; label := NIL;
  1259.           qualident (x, FALSE);
  1260.           IF
  1261.             (x.mode # Var) OR (x.lev # (OCC.level)) OR (x.typ.size # 4)
  1262.           THEN
  1263.             OCS.Mark (352); proc.a1 := 0
  1264.           ELSE proc.a1 := x.a0
  1265.           END;
  1266.           CheckSym (comma);
  1267.           IF sym = minus THEN proc.a0 := -1; OCS.Get (sym)
  1268.           ELSE proc.a0 := 1
  1269.           END;
  1270.           IF (sym = number) & (OCS.numtyp = 2) THEN
  1271.             proc.a0 := proc.a0 * OCS.intval; OCS.Get (sym)
  1272.           ELSE OCS.Mark (17)
  1273.           END;
  1274.         ELSE OCS.Mark (342); label := NIL
  1275.         END;
  1276.         CheckSym (close);
  1277.         IF (sysflg = M2Proc) OR (sysflg = CProc) THEN OCS.Warn (923) END
  1278.       ELSIF sysflg # OberonFlag THEN
  1279.         OCS.Mark (342); label := NIL
  1280.       END;
  1281.  
  1282.       INC (OCC.level); OCT.OpenScope (OCC.level);
  1283.  
  1284.       (* work out offset of procedure parameters *)
  1285.       IF sysflg # OberonFlag THEN
  1286.         psize := 0
  1287.       ELSIF (mode = LProc) & (OCC.level > 1) THEN
  1288.         psize := LParOrg (* return address + frame ptr + static link *)
  1289.       ELSIF (mode = XProc)
  1290.           & ~OCS.pragma [OCS.longVars]
  1291.           & ~OCM.SmallData & ~OCM.Resident
  1292.       THEN (* return address + frame ptr + saved global var base *)
  1293.         psize := XParOrg
  1294.       ELSE (* return address + frame ptr *)
  1295.         psize := ParOrg
  1296.       END
  1297.     END;
  1298.  
  1299.     proc.mode := mode; proc.typ := OCT.notyp;
  1300.     IF forward THEN proc.fwd := TRUE ELSE proc.fwd := FALSE END;
  1301.  
  1302.     IF sym = lparen THEN (* Get formal parameters *)
  1303.       OCS.Get (sym); FormalParameters (proc.typ, psize, sysflg)
  1304.     ELSIF mode = TProc THEN (* fixup receiver parameter *)
  1305.       par := OCT.topScope.right;
  1306.       IF par # NIL THEN
  1307.         par.a0 := psize;
  1308.         IF par.mode = Ind THEN INC (psize, RecDescSize)
  1309.         ELSE INC (psize, AdrSize)
  1310.         END
  1311.       END
  1312.     END;
  1313.     proc.link := OCT.topScope.right;
  1314.  
  1315.     IF proc1 # NIL THEN
  1316.       IF mode = TProc THEN (* forward declaration or redefinition *)
  1317.         IF
  1318.           ~proc1.fwd & (rtyp.strobj.visible = OCT.Exp)
  1319.           & (proc1.visible = OCT.Exp) & (proc.visible # OCT.Exp)
  1320.         THEN (* Redefined procedure must be exported *)
  1321.           OCS.Mark (330)
  1322.         END;
  1323.         OCH.CompareParLists (proc.link.link, proc1.link.link);
  1324.       ELSE (* forward declaration *)
  1325.         OCH.CompareParLists (proc.link, proc1.link);
  1326.       END;
  1327.       IF proc.typ # proc1.typ THEN OCS.Mark (118) END;
  1328.       IF
  1329.         (((mode = TProc) & (proc.a1 = proc1.a1)) OR (mode # TProc))
  1330.         & proc1.fwd
  1331.       THEN (* forward declaration *)
  1332.         proc := proc1; proc.link := OCT.topScope.right
  1333.       END
  1334.     END;
  1335.  
  1336.     IF forward OR (~proc.fwd) THEN
  1337.       IF mode = TProc THEN
  1338.         IF rtyp # OCT.undftyp THEN
  1339.           proc.left := rtyp.link; rtyp.link := proc;
  1340.           OCT.MakeTProcLabel (rtyp, proc)
  1341.         END
  1342.       ELSIF sysflg = OberonFlag THEN
  1343.         OCT.MakeProcLabel (proc)
  1344.       ELSE
  1345.         proc.label := label
  1346.       END
  1347.     END;
  1348.     IF ~forward THEN proc.fwd := FALSE END;
  1349.  
  1350.     IF body THEN
  1351.       CheckSym (semicolon); OCT.topScope.typ := proc.typ;
  1352.  
  1353.       OCH.StartProcedure (proc);
  1354.       Block (proc, dsize, retList);
  1355.       (* proc.link := OCT.topScope.right; (* update *) *)
  1356.       OCH.EndProcBody (proc, SHORT (psize), retList, dsize # 0);
  1357.       OCS.ResetProcSwitches ();
  1358.  
  1359.       (* Check size of local variables *)
  1360.       IF dsize > ProcVarSize THEN OCS.Mark (209); dsize := 0 END;
  1361.  
  1362.       (* Check name at end of procedure *)
  1363.       IF sym = ident THEN
  1364.         IF OCT.InsertName (OCS.name) # proc.name THEN OCS.Mark (4) END;
  1365.         OCS.Get (sym)
  1366.       ELSE
  1367.         OCS.Mark (10)
  1368.       END;
  1369.     END; (* IF *)
  1370.  
  1371.     IF proc.link # NIL THEN
  1372.       par := proc.link; WHILE IsParam (par.link) DO par := par.link END;
  1373.       par.link := NIL
  1374.     END;
  1375.     DEC (OCC.level); OCT.CloseScope ()
  1376.   END; (* IF *)
  1377. END ProcedureDeclaration;
  1378.  
  1379. (*------------------------------------*)
  1380. (*
  1381.   $  CaseLabelList  =  CaseLabels {"," CaseLabels}.
  1382.   $  CaseLabels  =  ConstExpression [".." ConstExpression].
  1383. *)
  1384. PROCEDURE CaseLabelList (
  1385.   LabelForm : INTEGER; VAR n : INTEGER; VAR tab : ARRAY OF OCH.LabelRange);
  1386.  
  1387.   (* CONST pname = "CaseLabelList"; *)
  1388.  
  1389.   VAR
  1390.     x, y : OCT.Item; i, f, g : INTEGER;
  1391.  
  1392. BEGIN (* CaseLabelList *)
  1393.   IF ~(LabelForm IN labeltyps) THEN OCS.Mark (61) END;
  1394.   LOOP
  1395.     ConstExpression (x); f := x.typ.form;
  1396.     IF (f = String) & (x.a1 <= 2) THEN
  1397.       x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  1398.     END;
  1399.     IF f IN intSet THEN
  1400.       IF LabelForm < f THEN OCS.Mark (60) END
  1401.     ELSIF f # LabelForm THEN
  1402.       OCS.Mark (60)
  1403.     END;
  1404.     IF sym = upto THEN
  1405.       OCS.Get (sym); ConstExpression (y); g := y.typ.form;
  1406.       IF (g = String) & (y.a1 <= 2) THEN
  1407.         y.a0 := y.a2; y.typ := OCT.chartyp; g := Char
  1408.       END;
  1409.       IF (g # f) & ~((f IN intSet) & (g IN intSet)) THEN
  1410.         OCS.Mark (60)
  1411.       END;
  1412.       IF y.a0 < x.a0 THEN OCS.Mark (63); y.a0 := x.a0 END
  1413.     ELSE
  1414.       y := x
  1415.     END;
  1416.     (* enter label range into ordered table *)
  1417.     i := n;
  1418.     IF i < NofCases THEN
  1419.       LOOP
  1420.         IF i = 0 THEN EXIT END;
  1421.         IF tab [i-1].low <= y.a0 THEN
  1422.           IF tab[i-1].high >= x.a0 THEN OCS.Mark (62) END;
  1423.           EXIT
  1424.         END;
  1425.         tab [i] := tab[i-1]; DEC (i)
  1426.       END; (* LOOP *)
  1427.       tab[i].low := x.a0; tab[i].high := y.a0;
  1428.       tab[i].label := OCC.pc; INC (n)
  1429.     ELSE
  1430.       OCS.Mark (213)
  1431.     END;
  1432.     IF sym = comma THEN
  1433.       OCS.Get (sym)
  1434.     ELSIF (sym = number) OR (sym = ident) THEN
  1435.       OCS.Mark (19)
  1436.     ELSE
  1437.       EXIT
  1438.     END;
  1439.   END; (* LOOP *)
  1440. END CaseLabelList;
  1441.  
  1442. (*------------------------------------*)
  1443. (*
  1444.   $  StatementSequence  =  statement {";" statement}.
  1445.  
  1446.   $  statement  =  [assignment | ProcedureCall |
  1447.   $    IfStatement | CaseStatement | WhileStatement | RepeatStatement |
  1448.   $    LoopStatement | WithStatement | EXIT | RETURN [expression] ].
  1449.  
  1450.   $  assignment  =  designator ":=" expression.
  1451.  
  1452.   $  ProcedureCall  =  designator [ActualParameters].
  1453.  
  1454.   $  IfStatement  =  IF expression THEN StatementSequence
  1455.   $    {ELSIF expression THEN StatementSequence}
  1456.   $    [ELSE StatementSequence]
  1457.   $    END.
  1458.  
  1459.   $  CaseStatement  =  CASE expression OF case {"|" case}
  1460.   $    [ELSE StatementSequence] END.
  1461.   $  case  =  [CaseLabelList ":" StatementSequence].
  1462.  
  1463.   $  WhileStatement  =  WHILE expression DO StatementSequence END.
  1464.  
  1465.   $  RepeatStatement  =   REPEAT StatementSequence UNTIL expression.
  1466.  
  1467.   $  LoopStatement  =  LOOP StatementSequence END.
  1468.  
  1469.   $  WithStatement  =  WITH qualident ":" qualident DO
  1470.   $    StatementSequence END.
  1471. *)
  1472. PROCEDURE StatSeq (VAR retList : LONGINT);
  1473.  
  1474.   (* CONST pname = "StatSeq"; *)
  1475.  
  1476.   VAR
  1477.     fpar : OCT.Object; xtyp : OCT.Struct; stackload, L0, L1 : LONGINT;
  1478.     x, rcvr, y, z, step : OCT.Item; ExitIndex : INTEGER;
  1479.     R, R1 : OCC.RegState; mask : SET;
  1480.  
  1481.   (*------------------------------------*)
  1482.   PROCEDURE CasePart ();
  1483.  
  1484.     (* CONST pname = "CasePart"; *)
  1485.  
  1486.     VAR
  1487.       x : OCT.Item; n : INTEGER; L0, L1, L2 : LONGINT;
  1488.       tab : ARRAY NofCases OF OCH.LabelRange;
  1489.  
  1490.   BEGIN (* CasePart *)
  1491.     n := 0; L1 := 0;
  1492.     Expression (x); OCH.CaseIn (x, L0); CheckSym (of);
  1493.     R := OCC.regState;
  1494.     LOOP
  1495.       IF sym < bar THEN
  1496.         CaseLabelList (x.typ.form, n, tab);  CheckSym (colon);
  1497.         OCC.regState := R; StatSeq (retList); OCH.FJ (L1)
  1498.       END;
  1499.       IF sym = bar THEN OCS.Get (sym) ELSE EXIT END
  1500.     END; (* LOOP *)
  1501.     L2 := OCC.pc;
  1502.     IF sym = else THEN
  1503.       OCS.Get (sym); OCC.regState := R; StatSeq (retList); OCH.FJ (L1)
  1504.     ELSE
  1505.       IF OCS.pragma [OCS.caseChk] THEN OCC.Trap (OCC.CaseCheck)
  1506.       ELSE OCH.FJ (L1)
  1507.       END
  1508.     END;
  1509.     OCH.CaseOut (x, L0, L1, L2, n, tab)
  1510.   END CasePart;
  1511.  
  1512. BEGIN (* StatSeq *)
  1513.   R := OCC.regState;
  1514.   LOOP
  1515.     IF sym < ident THEN (* illegal symbol *)
  1516.       OCS.Mark (14);
  1517.       REPEAT OCS.Get (sym) UNTIL sym >= ident;
  1518.     END;
  1519.  
  1520.     IF sym = ident THEN (* assignment or procedure call *)
  1521.       qualident (x, TRUE); selector (x, rcvr);
  1522.       IF sym = becomes THEN (* assignment *)
  1523.         OCS.Get (sym); Expression (y); OCH.Assign (x, y, FALSE)
  1524.       ELSIF sym = eql THEN (* typo ? *)
  1525.         OCS.Mark (33); OCS.Get (sym); Expression (y);
  1526.         OCH.Assign (x, y, FALSE)
  1527.       ELSIF x.mode = SProc THEN (* standard procedure call *)
  1528.         StandProcCall (x); IF x.typ # OCT.notyp THEN OCS.Mark (55) END
  1529.       ELSE (* procedure call *)
  1530.         OCH.PrepCall (x, fpar, mask);
  1531.         IF x.mode IN {TProc, LibCall} THEN
  1532.           OCC.SaveRegisters (R1, rcvr, mask);
  1533.           IF x.mode = TProc THEN
  1534.             OCH.Receiver (TProc, rcvr, x.obj.link, mask)
  1535.           ELSE
  1536.             OCH.Receiver (LibCall, rcvr, NIL, mask)
  1537.           END
  1538.         ELSE
  1539.           OCC.SaveRegisters (R1, x, mask);
  1540.         END;
  1541.         stackload := 0;
  1542.         IF sym = lparen THEN
  1543.           OCS.Get (sym); ActualParameters (fpar, x.mode, stackload);
  1544.           CheckSym (rparen);
  1545.         ELSIF IsParam (fpar) THEN (* parameters missing *)
  1546.           OCS.Mark (65)
  1547.         END;
  1548.         OCH.Call (x, rcvr, stackload, mask);
  1549.         IF x.mode # LibCall THEN OCC.ForgetRegs END;
  1550.         OCC.RestoreRegisters (R1, x);
  1551.         IF x.typ # OCT.notyp THEN OCS.Mark (55) END;
  1552.       END;
  1553.  
  1554.     ELSIF sym = if THEN (* if statement *)
  1555.       OCS.Get (sym); Expression (x); OCH.CFJ (x, L0);
  1556.       OCC.FreeRegs (R); R := OCC.regState;
  1557.       CheckSym (then); StatSeq (retList); L1 := 0;
  1558.       WHILE sym = elsif DO
  1559.         OCS.Get (sym); OCH.FJ (L1); OCC.FixLink (L0);
  1560.         OCC.regState := R; Expression (x); OCH.CFJ (x, L0);
  1561.         OCC.FreeRegs (R); R := OCC.regState;
  1562.         CheckSym (then); StatSeq (retList)
  1563.       END;
  1564.       IF sym = else THEN
  1565.         OCS.Get (sym); OCH.FJ (L1); OCC.FixLink (L0);
  1566.         OCC.regState := R; StatSeq (retList)
  1567.       ELSE
  1568.         OCC.FixLink (L0)
  1569.       END;
  1570.       OCC.FixLink (L1); CheckSym (end); OCC.ForgetRegs
  1571.  
  1572.     ELSIF sym = case THEN (* case statement *)
  1573.       OCS.Get (sym); CasePart (); CheckSym (end); OCC.ForgetRegs
  1574.  
  1575.     ELSIF sym = while THEN (* while statement *)
  1576.       OCC.ForgetRegs; R := OCC.regState;
  1577.       OCS.Get (sym); L1 := OCC.pc; Expression (x);
  1578.       OCH.CFJ (x, L0); OCC.FreeRegs (R);
  1579.       CheckSym (do); StatSeq (retList);
  1580.       OCH.BJ (L1); OCC.FixLink (L0);
  1581.       CheckSym (end); OCC.ForgetRegs
  1582.  
  1583.     ELSIF sym = repeat THEN (* repeat statement *)
  1584.       OCC.ForgetRegs; R := OCC.regState;
  1585.       OCS.Get (sym); L0 := OCC.pc; StatSeq (retList);
  1586.       IF sym = until THEN
  1587.         OCS.Get (sym); Expression (x); OCH.CBJ (x, L0)
  1588.       ELSE
  1589.         OCS.Mark (43)
  1590.       END;
  1591.       OCC.ForgetRegs
  1592.  
  1593.     ELSIF sym = for THEN
  1594.       OCC.ForgetRegs; R := OCC.regState;
  1595.       OCS.Get (sym);
  1596.       IF sym = ident THEN
  1597.         qualident (x, FALSE);
  1598.         IF x.lev < 0 THEN OCS.Mark (327)
  1599.         ELSIF ~(x.typ.form IN intSet) THEN OCS.Mark (314)
  1600.         END;
  1601.         CheckSym (becomes); Expression (y);
  1602.         IF ~(y.typ.form IN intSet) THEN OCS.Mark (315) END;
  1603.         CheckSym (to); Expression (z);
  1604.         IF ~(z.typ.form IN intSet) THEN OCS.Mark (315) END;
  1605.         IF sym = by THEN OCS.Get (sym); ConstExpression (step);
  1606.           IF ~(step.typ.form IN intSet) THEN OCS.Mark (17)
  1607.           ELSIF step.a0 = 0 THEN OCS.Mark (316); step.a0 := 1
  1608.           END;
  1609.         ELSE step.mode := Con; step.a0 := 1; step.typ := OCT.sinttyp
  1610.         END;
  1611.         OCH.BeginFor (x, y, z, step, R, L0, L1);
  1612.         CheckSym (do); StatSeq (retList);
  1613.         OCH.EndFor (x, step, z, L0, L1); CheckSym (end)
  1614.       ELSE OCS.Mark (10)
  1615.       END;
  1616.       OCC.ForgetRegs
  1617.  
  1618.     ELSIF sym = loop THEN (* loop statement *)
  1619.       OCC.ForgetRegs; R := OCC.regState;
  1620.       OCS.Get (sym); ExitIndex := ExitNo; INC (LoopLevel);
  1621.       L0 := OCC.pc; StatSeq (retList); OCH.BJ (L0); DEC (LoopLevel);
  1622.       WHILE ExitNo > ExitIndex DO
  1623.         DEC (ExitNo); OCC.fixup (LoopExit [ExitNo])
  1624.       END;
  1625.       CheckSym (end); OCC.ForgetRegs
  1626.  
  1627.     ELSIF sym = with THEN (* regional type guard *)
  1628.       L1 := 0;
  1629.       REPEAT
  1630.         OCC.regState := R; OCS.Get (sym); x.obj := NIL; xtyp := NIL;
  1631.         IF sym = ident THEN (* got variable OK *)
  1632.           qualident (x, FALSE); CheckSym (colon);
  1633.           IF sym = ident THEN
  1634.             qualident (y, FALSE);
  1635.             IF y.mode = Typ THEN (* got type OK *)
  1636.               IF x.obj # NIL THEN
  1637.                 xtyp := x.typ; x.obj.typ := y.typ; OCE.TypTest (x, y, TRUE)
  1638.               ELSE OCS.Mark (130) (* variable has anonymous type *)
  1639.               END
  1640.             ELSE OCS.Mark (52) (* not a type *)
  1641.             END
  1642.           ELSE OCS.Mark (10)
  1643.           END
  1644.         ELSE OCS.Mark (10)
  1645.         END;
  1646.         CheckSym (do); OCH.CFJ (x, L0); OCC.FreeRegs (R); StatSeq (retList);
  1647.         IF (sym = bar) OR (sym = else) THEN
  1648.           OCH.FJ (L1); OCC.FixLink (L0)
  1649.         END;
  1650.         IF xtyp # NIL THEN x.obj.typ := xtyp END;
  1651.       UNTIL sym # bar;
  1652.       IF sym = else THEN OCS.Get (sym); OCC.regState := R; StatSeq (retList)
  1653.       ELSIF OCS.pragma [OCS.typeChk] THEN OCC.TypeTrap (L0)
  1654.       ELSE OCC.FixLink (L0)
  1655.       END;
  1656.       OCC.FixLink (L1); CheckSym (end); OCC.ForgetRegs
  1657.  
  1658.     ELSIF sym = exit THEN (* Loop exit statement *)
  1659.       OCS.Get (sym); L0 := 0; OCH.FJ (L0);
  1660.       IF LoopLevel = 0 THEN OCS.Mark (45)
  1661.       ELSIF ExitNo < NumLoopLevels THEN
  1662.         LoopExit [ExitNo] := L0; INC (ExitNo)
  1663.       ELSE OCS.Mark (214)
  1664.       END;
  1665.  
  1666.     ELSIF sym = return THEN (* Procedure return statement *)
  1667.       OCS.Get (sym);
  1668.       IF OCC.level > 0 THEN (* Return from procedure *)
  1669.         IF sym < semicolon THEN
  1670.           Expression (x); OCH.Result (x, OCT.topScope.typ);
  1671.           OCC.ForgetRegs
  1672.         ELSIF OCT.topScope.typ # OCT.notyp THEN (* expression missing *)
  1673.           OCS.Mark (124)
  1674.         END;
  1675.         OCH.FJ (retList)
  1676.       ELSE (* return from module body *)
  1677.         IF sym < semicolon THEN Expression (x); OCS.Mark (124) END;
  1678.         OCH.FJ (retList)
  1679.       END;
  1680.     END;
  1681.  
  1682.     OCC.FreeRegs (R);
  1683.  
  1684.     IF sym = semicolon THEN
  1685.       OCS.Get (sym)
  1686.     ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN
  1687.       OCS.Mark (38)
  1688.     ELSE
  1689.       EXIT
  1690.     END;
  1691.   END; (* LOOP *)
  1692. END StatSeq;
  1693.  
  1694. (*------------------------------------*)
  1695. (*
  1696.   $  module  =  MODULE ident ";"  [ImportList]
  1697.   $    DeclarationSequence [BEGIN StatementSequence] END ident "." .
  1698.        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
  1699.  
  1700.   $  ProcedureBody  =  DeclarationSequence [BEGIN StatementSequence] END.
  1701.                        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
  1702.  
  1703.   $  DeclarationSequence  =  {CONST {ConstantDeclaration ";"} |
  1704.   $      TYPE {TypeDeclaration ";"} | VAR {VariableDeclaration ";"}}
  1705.   $      {ProcedureDeclaration ";" | ForwardDeclaration ";"}.
  1706. *)
  1707. PROCEDURE Block (
  1708.   proc : OCT.Object; VAR dsize : LONGINT; VAR retList : LONGINT);
  1709.  
  1710.   (* CONST pname = "Block"; *)
  1711.  
  1712.   VAR
  1713.     typ, forward : OCT.Struct;
  1714.     obj, first, last : OCT.Object;
  1715.     x : OCT.Item;
  1716.     L0 : LONGINT;
  1717.     adr, size : LONGINT;
  1718.     mk : SHORTINT;
  1719.     id0 : ARRAY 32 OF CHAR;
  1720.  
  1721. BEGIN (* Block *)
  1722.   (* Calculate base address of variables *)
  1723.   IF OCC.level = 0 THEN (* +ve offsets from module variable base *)
  1724.     adr := dsize
  1725.   ELSE (* -ve offsets from frame pointer *)
  1726.     adr := -dsize
  1727.   END;
  1728.  
  1729.   last := OCT.topScope.right;
  1730.   IF last # NIL THEN
  1731.     WHILE last.link # NIL DO last := last.link END;
  1732.   END;
  1733.  
  1734.   LOOP
  1735.     IF sym = const THEN (* Constant declaration(s) *)
  1736.       OCS.Get (sym);
  1737.       WHILE sym = ident DO
  1738.         COPY (OCS.name, id0); CheckMark (mk, FALSE);
  1739.         IF sym = eql THEN
  1740.           OCS.Get (sym); ConstExpression (x)
  1741.         ELSIF sym = becomes THEN
  1742.           OCS.Mark (9); OCS.Get (sym); ConstExpression (x)
  1743.         ELSE
  1744.           OCS.Mark (9)
  1745.         END;
  1746.  
  1747.         (* Enforce limitation on aliasing imported string constants *)
  1748.         IF (x.lev < 0) & (x.typ = OCT.stringtyp) & (x.a1 > 2) THEN
  1749.           OCS.Mark (323)
  1750.         END;
  1751.  
  1752.         (* Insert in symbol table *)
  1753.         OCT.Insert (id0, obj, SHORT (x.mode));
  1754.         obj.typ := x.typ; obj.a0 := x.a0; obj.a1 := x.a1; obj.a2 := x.a2;
  1755.         obj.visible := mk; obj.label := x.label;
  1756.  
  1757.         CheckSym (semicolon)
  1758.       END; (* WHILE *)
  1759.     END; (* IF *)
  1760.  
  1761.     IF sym = type THEN (* Type declaration(s) *)
  1762.       OCS.Get (sym);
  1763.       WHILE sym = ident DO
  1764.         (* Insert in symbol table *)
  1765.         typ := OCT.undftyp; OCT.Insert (OCS.name, obj, Typ);
  1766.         forward := obj.typ; obj.typ := OCT.notyp;
  1767.         CheckMark (obj.visible, FALSE);
  1768.  
  1769.         IF sym = eql THEN
  1770.           OCS.Get (sym); Type (typ, TRUE);
  1771.         ELSIF (sym = becomes) OR (sym = colon) THEN
  1772.           OCS.Mark (9);
  1773.           OCS.Get (sym); Type (typ, TRUE);
  1774.         ELSE
  1775.           OCS.Mark (9); typ := OCT.undftyp
  1776.         END;
  1777.  
  1778.         obj.typ := typ;
  1779.         IF typ.strobj = NIL THEN typ.strobj := obj END;
  1780.         IF forward # NIL THEN (* fixup *) SetPtrBase (forward, typ) END;
  1781.  
  1782.         CheckSym (semicolon);
  1783.       END; (* WHILE *)
  1784.     END; (* IF *)
  1785.  
  1786.     IF sym = var THEN (* Variable declarations *)
  1787.       (*IF (OCC.level = 0) & ~OCS.createObj THEN OCS.Mark (918) END;*)
  1788.       OCS.Get (sym);
  1789.       WHILE sym = ident DO
  1790.         (* Insert in symbol table *)
  1791.         OCT.Insert (OCS.name, obj, Var); CheckMark (obj.visible, TRUE);
  1792.         IF (obj # last) & (obj.link = NIL) THEN
  1793.           IF last = NIL THEN OCT.topScope.right := obj
  1794.           ELSE last.link := obj
  1795.           END;
  1796.           first := obj; last := obj
  1797.         END;
  1798.  
  1799.         LOOP (* Get identifier list *)
  1800.           IF sym = comma THEN     OCS.Get (sym)
  1801.           ELSIF sym = ident THEN  OCS.Mark (19)
  1802.           ELSE                    EXIT
  1803.           END;
  1804.           IF sym = ident THEN
  1805.             OCT.Insert (OCS.name, obj, Var); CheckMark (obj.visible, TRUE);
  1806.             IF (obj # last) & (obj.link = NIL) THEN
  1807.               last.link := obj; last := obj
  1808.             END
  1809.           ELSE
  1810.             OCS.Mark (10)
  1811.           END;
  1812.         END; (* LOOP *)
  1813.  
  1814.         (* Get type *)
  1815.         CheckSym (colon); Type (typ, FALSE);
  1816.         size := typ.size;
  1817.         IF (size > 1) & ODD (size) THEN INC (size) END;
  1818.  
  1819.         (* Calculate variable addresses *)
  1820.         IF OCC.level = 0 THEN (* Global variable *)
  1821.           IF (size > 1) & ODD (adr) THEN INC (adr) END; (* Word align *)
  1822.           WHILE first # NIL DO
  1823.             first.typ := typ; first.a0 := adr;
  1824.             IF (OCM.VarLimit - size) < adr THEN OCS.Mark (209)
  1825.             ELSE INC (adr, size)
  1826.             END;
  1827.             first := first.link
  1828.           END;
  1829.         ELSE                  (* Local procedure variable *)
  1830.           IF (size > 1) & ODD (adr) THEN DEC (adr) END; (* Word align *)
  1831.           WHILE first # NIL DO
  1832.             first.typ := typ;
  1833.             IF (OCM.LVarLimit + size) > adr THEN OCS.Mark (209)
  1834.             ELSE DEC (adr, size)
  1835.             END;
  1836.             first.a0 := adr; first := first.link
  1837.           END;
  1838.         END;
  1839.  
  1840.         CheckSym (semicolon);
  1841.       END; (* WHILE *)
  1842.     END; (* IF *)
  1843.     IF (sym < const) OR (sym > var) THEN EXIT END;
  1844.   END; (* LOOP *)
  1845.  
  1846.   CheckUndefPointerTypes ();
  1847.  
  1848.   IF (OCC.level = 0) & (dsize = 0) & ~OCM.SmallData & ~OCM.Resident THEN
  1849.     OCS.pragma [OCS.longVars] := TRUE
  1850.   END;
  1851.  
  1852.   WHILE sym = procedure DO (* Procedure declarations *)
  1853.     OCS.Get (sym); ProcedureDeclaration (); CheckSym (semicolon)
  1854.   END;
  1855.  
  1856.   CheckForwardProcs ();
  1857.  
  1858.   (* Calculate data size (rounded up to even value) *)
  1859.   IF OCC.level = 0 THEN dsize := adr
  1860.   ELSE                  dsize := -adr
  1861.   END;
  1862.   IF ODD (dsize) THEN INC (dsize) END;
  1863.  
  1864.   retList := 0; (* set up list of return branches *)
  1865.   OCC.ForgetRegs;
  1866.   IF OCC.level = 0 THEN
  1867.     OCH.StartModuleBody (dsize, retList)
  1868.   ELSE
  1869.     IF proc.link = NIL THEN proc.link := OCT.topScope.right END;
  1870.     OCH.StartProcBody (proc, dsize)
  1871.   END;
  1872.   IF sym = begin THEN (* Main body of block *)
  1873.     OCS.Get (sym); StatSeq (retList);
  1874.   END;
  1875.  
  1876.   CheckSym (end);
  1877. END Block;
  1878.  
  1879. (*------------------------------------*)
  1880. (*
  1881.   $  module  =  MODULE ident ";"  [ImportList] DeclarationSequence
  1882.   $      [BEGIN StatementSequence] END ident "." .
  1883.   $  ImportList  =  IMPORT import {"," import} ";" .
  1884.   $  import  =  identdef [":" ident].
  1885. *)
  1886. PROCEDURE CompilationUnit ( source : Files.File);
  1887.  
  1888.   (* CONST pname = "CompilationUnit"; *)
  1889.  
  1890.   VAR
  1891.     L0 : INTEGER; retList : LONGINT; ch : CHAR;
  1892.     time, date, key, dsize : LONGINT;
  1893.     name, alias : ARRAY 32 OF CHAR;
  1894.     FName : ARRAY 256 OF CHAR;
  1895.  
  1896. BEGIN (* CompilationUnit *)
  1897.   procNo := 1; dsize := 0; LoopLevel := 0; ExitNo := 0;
  1898.   defaultFlag := OberonFlag;
  1899.   OCC.Init (); OCT.Init (); OCS.Init (source);
  1900.  
  1901.   REPEAT OCS.Get (sym) UNTIL (sym = eof) OR (sym = module);
  1902.   IF sym # module THEN
  1903.     OCOut.Str0 (OCStrings.Compiler1);
  1904.     RETURN
  1905.   END;
  1906.  
  1907.   OCS.allowOptions := FALSE; OCS.Get (sym);
  1908.   IF sym = lbrak THEN SysFlag (defaultFlag) END;
  1909.  
  1910.   IF sym = ident THEN
  1911.     L0 := 0; ch := OCS.name [0];
  1912.     WHILE (ch # 0X) & (L0 < ModNameLen) DO
  1913.       OCT.ModuleName [L0] := ch; INC (L0); ch := OCS.name [L0];
  1914.     END;
  1915.     OCT.ModuleName [L0] := 0X;
  1916.     IF ch # 0X THEN OCS.Mark (334) END;
  1917.  
  1918.     OCS.StartModule (OCT.ModuleName);
  1919.     OCT.StartModule ();
  1920.     OCC.StartModule (OCT.ModuleName);
  1921.     OCT.OpenScope (0);
  1922.  
  1923.     OCS.Get (sym);
  1924.     IF sym = lbrak THEN (* List of external modules *)
  1925.       REPEAT
  1926.         OCS.Get (sym);
  1927.         IF sym = string THEN OCT.ExtLib (); OCS.Get (sym)
  1928.         ELSE OCS.Mark (342)
  1929.         END
  1930.       UNTIL sym # comma;
  1931.       CheckSym (rbrak); CheckNonStandard ()
  1932.     END;
  1933.     CheckSym (semicolon);
  1934.  
  1935.     OCH.ModulePrologue ();
  1936.  
  1937.     IF sym = import THEN
  1938.       OCS.Get (sym);
  1939.  
  1940.       LOOP
  1941.         IF sym = ident THEN
  1942.           COPY (OCS.name, alias); OCS.Get (sym);
  1943.           name := alias;
  1944.           IF sym = becomes THEN
  1945.             OCS.Get (sym);
  1946.             IF sym = ident THEN COPY (OCS.name, name); OCS.Get (sym);
  1947.             ELSE OCS.Mark (10);
  1948.             END
  1949.           END;
  1950.           OCT.Import (name, alias)
  1951.         ELSE OCS.Mark (10)
  1952.         END;
  1953.  
  1954.         IF sym = comma THEN     OCS.Get (sym);
  1955.         ELSIF sym = ident THEN  OCS.Mark (19);
  1956.         ELSE                    EXIT;
  1957.         END;
  1958.       END; (* LOOP *)
  1959.  
  1960.       CheckSym (semicolon);
  1961.     END; (* IF *)
  1962.  
  1963.     IF ~OCS.scanerr THEN
  1964.       Block (NIL, dsize, retList);
  1965.       OCH.EndModuleBody (dsize, retList);
  1966.  
  1967.       IF sym = ident THEN
  1968.         IF OCS.name # OCT.ModuleName THEN OCS.Mark (4) END;
  1969.         OCS.Get (sym);
  1970.       ELSE
  1971.         OCS.Mark (10);
  1972.       END;
  1973.  
  1974.       IF sym # period THEN OCS.Mark (18) END;
  1975.  
  1976.       IF ~OCS.scanerr OR OCM.Force THEN
  1977.         OCC.AllocSlots;
  1978.         OberonClock.GetClock (time, date);
  1979.         key := (date MOD 4000H) * 20000H + time;
  1980.         OCT.Export (OCT.ModuleName, newSF, key);
  1981.         IF ~OCS.scanerr OR OCM.Force THEN
  1982.           OCM.ObjectFileName (OCT.ModuleName, FName);
  1983.           IF OCM.Verbose THEN OCOut.Str1 (OCStrings.Compiler2, FName) END;
  1984.           OCC.OutCode (FName, key, dsize);
  1985.           IF OCM.Verbose THEN
  1986.             OCOut.Int4
  1987.               ( OCStrings.Compiler3, OCC.pc, OCC.DataSize(), dsize,
  1988.                 OCC.pc + dsize + OCC.DataSize ());
  1989.           END
  1990.         END
  1991.       END (* IF *)
  1992.     END; (* IF *)
  1993.     OCT.CloseScope ();
  1994.     OCT.EndModule (); OCS.EndModule ();
  1995.   ELSE
  1996.     OCOut.Str0 (OCStrings.Compiler4)
  1997.   END;
  1998.  
  1999. END CompilationUnit;
  2000.  
  2001. (*------------------------------------*)
  2002. PROCEDURE ReportTime (VAR t1, t2 : ti.TimeVal);
  2003.  
  2004.   PROCEDURE Pair ( ch : CHAR; x : LONGINT );
  2005.   BEGIN (* Pair *)
  2006.     OCOut.Char (ch);
  2007.     OCOut.Char (CHR (x DIV 10 + 30H));
  2008.     OCOut.Char (CHR (x MOD 10 + 30H))
  2009.   END Pair;
  2010.  
  2011. BEGIN (* ReportTime *)
  2012.   ti.SubTime (t2, t1);
  2013.   OCOut.Str ("    Elapsed time =");
  2014.   Pair (" ", t2.secs DIV 60);
  2015.   Pair (":", t2.secs MOD 60);
  2016.   OCOut.Char ("."); OCOut.Int (t2.micro DIV 100000);
  2017.   OCOut.Ln; OCOut.Ln
  2018. END ReportTime;
  2019.  
  2020. (*------------------------------------*)
  2021. PROCEDURE Reset ();
  2022.  
  2023.   VAR
  2024.     t1, t2 : ti.TimeVal;
  2025.  
  2026. BEGIN (* Reset *)
  2027.   IF OCM.Verbose THEN
  2028.     OCOut.Str0 (OCStrings.OC8);
  2029.     ti.GetSysTime (t1);
  2030.   END;
  2031.  
  2032.   OCC.Close (); OCT.Close ();
  2033.   Kernel.GC;
  2034.  
  2035.   IF OCM.Verbose THEN
  2036.     ti.GetSysTime (t2);
  2037.     ReportTime (t1, t2)
  2038.   END;
  2039. END Reset;
  2040.  
  2041. (*------------------------------------*)
  2042. PROCEDURE Compile* (source : ARRAY OF CHAR; newSymFile : BOOLEAN);
  2043.  
  2044.   VAR
  2045.     t1, t2 : ti.TimeVal;
  2046.  
  2047. <*$CopyArrays-*>
  2048. BEGIN (* Compile *)
  2049.   IF OCM.Verbose THEN ti.GetSysTime (t1) END;
  2050.  
  2051.   file := Files.Old (source);
  2052.   IF file = NIL THEN
  2053.     OCOut.Str1 (OCStrings.OC6, source)
  2054.   ELSE
  2055.     OCOut.Str1 (OCStrings.OC7, source);
  2056.     newSF := newSymFile;
  2057.     CompilationUnit (file);
  2058.     IF OCS.scanerr THEN returnError := TRUE
  2059.     ELSIF OCS.warned THEN returnWarn := TRUE
  2060.     END;
  2061.     Files.Close (file); file := NIL
  2062.   END;
  2063.  
  2064.   IF OCM.Verbose THEN
  2065.     ti.GetSysTime (t2);
  2066.     ReportTime (t1, t2)
  2067.   END;
  2068.  
  2069.   Reset
  2070. END Compile;
  2071.  
  2072. (*------------------------------------*)
  2073. PROCEDURE Batch* (batchName : ARRAY OF CHAR; newSymFile : BOOLEAN);
  2074.  
  2075.   VAR
  2076.     sourceName : ARRAY 256 OF CHAR;
  2077.     i : INTEGER;
  2078.     ch : CHAR;
  2079.     t1, t2 : ti.TimeVal;
  2080.  
  2081. <*$CopyArrays-*>
  2082. BEGIN (* Batch *)
  2083.   batchFile := Files.Old (batchName);
  2084.   IF batchFile # NIL THEN
  2085.     IF OCM.Verbose THEN ti.GetSysTime (t1) END;
  2086.  
  2087.     Files.Set (r, batchFile, 0);
  2088.     LOOP
  2089.       Files.Read (r, ch);
  2090.       IF r.eof THEN EXIT END;
  2091.       WHILE ch <= " " DO (* Skip whitespace *)
  2092.         Files.Read (r, ch);
  2093.         IF r.eof THEN EXIT END
  2094.       END;
  2095.       i := 0;
  2096.       REPEAT
  2097.         sourceName [i] := ch; INC (i); Files.Read (r, ch)
  2098.       UNTIL r.eof OR (ch = "\n");
  2099.       sourceName [i] := 0X;
  2100.       Compile (sourceName, newSymFile);
  2101.       IF r.eof THEN EXIT END
  2102.     END;
  2103.     Files.Set (r, NIL, 0); Files.Close (batchFile); batchFile := NIL;
  2104.  
  2105.     IF OCM.Verbose THEN
  2106.       ti.GetSysTime (t2);
  2107.       OCOut.Str0 (OCStrings.OC10);
  2108.       ReportTime (t1, t2)
  2109.     END;
  2110.   ELSE
  2111.     OCOut.Str1 (OCStrings.OC11, batchName)
  2112.   END
  2113. END Batch;
  2114.  
  2115. (*------------------------------------*)
  2116. PROCEDURE Interactive* (newSymFile : BOOLEAN);
  2117.  
  2118.   CONST prompt = "Source file ? : ";
  2119.  
  2120.   VAR nameBuffer : ARRAY 256 OF CHAR;
  2121.  
  2122. BEGIN (* Interactive *)
  2123.   OCOut.Str0 (OCStrings.OC9);
  2124.   In.Open; In.Name (nameBuffer);
  2125.   IF nameBuffer [0] # 0X THEN
  2126.     Compile (nameBuffer, newSymFile);
  2127.     LOOP
  2128.       OCOut.Str0 (OCStrings.OC9);
  2129.       In.Open; In.Name (nameBuffer);
  2130.       IF nameBuffer = "" THEN EXIT END;
  2131.       Compile (nameBuffer, newSymFile)
  2132.     END
  2133.   END
  2134. END Interactive;
  2135.  
  2136. (*------------------------------------*)
  2137. PROCEDURE* Cleanup (VAR rc : LONGINT);
  2138.  
  2139. BEGIN (* Cleanup *)
  2140.   IF file # NIL THEN Files.Close (file); file := NIL END;
  2141.   IF batchFile # NIL THEN Files.Close (batchFile); batchFile := NIL END;
  2142.   IF ti.base # NIL THEN e.CloseDevice (tr); ti.base := NIL END;
  2143. END Cleanup;
  2144.  
  2145. (*------------------------------------*)
  2146. PROCEDURE Init ();
  2147.  
  2148. BEGIN (* Init *)
  2149.   Kernel.SetCleanup (Cleanup);
  2150.   returnWarn := FALSE; returnError := FALSE;
  2151.  
  2152.   NEW (tr);
  2153.   Errors.Assert
  2154.     ( e.OpenDevice (ti.timerName, ti.vBlank, tr, {}) = 0,
  2155.       "OC -- failed to open timer.device" );
  2156.   ti.base := tr.node.device;
  2157. END Init;
  2158.  
  2159. BEGIN (* Compiler *)
  2160.   Init
  2161. END Compiler.
  2162.  
  2163. (***************************************************************************
  2164.  
  2165.   $Log: Compiler.mod $
  2166.   Revision 5.31  1995/07/14  00:46:09  fjc
  2167.   - Temporarily disabled AssertChk pragma.
  2168.  
  2169.   Revision 5.30  1995/06/29  19:11:29  fjc
  2170.   - Removed code that was second-guessing the garbage collector
  2171.  
  2172.   Revision 5.29  1995/06/15  18:16:21  fjc
  2173.   - Changed the parameters to OCH.PrepCall().
  2174.  
  2175.   Revision 5.28  1995/06/04  22:52:04  fjc
  2176.   - Changed to reflect new interfaces to OCH procedures.
  2177.  
  2178.   Revision 5.27  1995/06/03  00:37:33  fjc
  2179.   - Uses new interface to OCH.PrepCall.
  2180.  
  2181.   Revision 5.26  1995/06/02  18:44:23  fjc
  2182.   - Implemented the SMALLDATA and RESIDENT options.
  2183.   - Enforces ExtendLimit.
  2184.   - Implemented the AssertChk pragma.
  2185.  
  2186.   Revision 5.25  1995/05/19  16:06:18  fjc
  2187.   - Uses OCOut for console IO.
  2188.   - Reinstated Interactive() procedure.
  2189.  
  2190.   Revision 5.24  1995/05/13  23:11:28  fjc
  2191.   - Changed INTEGER to LONGINT where necessary.
  2192.   - Moved Compile(), Batch(), etc. from OC.
  2193.  
  2194.   Revision 5.22  1995/04/02  13:57:16  fjc
  2195.   - Changed to implement the small data model.
  2196.  
  2197.   Revision 5.21  1995/03/25  17:12:16  fjc
  2198.   - Minor fix in HasTaggedPtr().
  2199.  
  2200.   Revision 5.20  1995/03/23  18:30:31  fjc
  2201.   - More work on remembering registers
  2202.  
  2203.   Revision 5.18  1995/03/09  19:13:32  fjc
  2204.   - Incorporated changes from 5.22.
  2205.  
  2206.   Revision 5.17  1995/02/27  17:11:46  fjc
  2207.   - Removed tracing code.
  2208.   - Changed to use new register handling procedures.
  2209.  
  2210.   Revision 5.16.1.1  1995/03/08  19:27:57  fjc
  2211.   - OC 5.22
  2212.  
  2213.   Revision 5.16  1995/02/08  13:56:11  fjc
  2214.   - OC 5.20
  2215.  
  2216.   Revision 5.15  1995/01/26  00:17:17  fjc
  2217.   - Release 1.5
  2218.  
  2219.   Revision 5.13  1995/01/09  13:59:06  fjc
  2220.   - Changed console output depending on OCM.Verbose.
  2221.  
  2222.   Revision 5.12  1995/01/05  11:39:48  fjc
  2223.   - Changed forceCode to OCM.Force.
  2224.  
  2225.   Revision 5.11  1995/01/03  21:26:02  fjc
  2226.   - Changed OCG to OCM.
  2227.   - Changed to use catalogs:
  2228.     - Uses OCM for console I/O instead of Out.
  2229.     - Gets text from OCStrings instead of hard-coding it.
  2230.  
  2231.   Revision 5.10  1994/12/16  17:43:38  fjc
  2232.   - Changed Symbol to Label.
  2233.   - Uses module OCG for constructing file names.
  2234.   - Changed handling of forward declarations.
  2235.   - Added call to OCC.AllocSlots().
  2236.  
  2237.   Revision 5.9  1994/11/13  11:40:01  fjc
  2238.   - Fixed bug in handling sysflags when module default was
  2239.     not Oberon.
  2240.   - Now allows braces in place of square brackets for some
  2241.     purposes.
  2242.  
  2243.   Revision 5.8  1994/10/23  16:34:03  fjc
  2244.   - Replaced StdIO with Out for console IO.
  2245.   - Uses new interface for module Strings.
  2246.   - Changed to reflect changes in interfaces to OCH and OCP.
  2247.  
  2248.   Revision 5.7  1994/09/25  18:12:09  fjc
  2249.   - Changed to reflect new object modes and system flags:
  2250.     - Removed code for parsing CPOINTER, BPOINTER and LIBCALL
  2251.       declarations.
  2252.     - Added code to parse system flags.
  2253.     - Added checks for system flags in record, pointer and
  2254.       procedure declarations.
  2255.   - Simplified checking for dynamic array types.
  2256.  
  2257.   Revision 5.6  1994/09/19  23:10:05  fjc
  2258.   - Re-implemented Amiga library calls
  2259.  
  2260.   Revision 5.5  1994/09/16  17:37:41  fjc
  2261.   - Removed defunct error message.
  2262.  
  2263.   Revision 5.4  1994/09/15  11:34:09  fjc
  2264.   - Merged in bug fix from 4.17.
  2265.  
  2266.   Revision 5.3  1994/09/15  10:44:05  fjc
  2267.   - Replaced switches with pragmas.
  2268.  
  2269.   Revision 5.2  1994/09/08  10:53:28  fjc
  2270.   - Changed to use pragmas/options.
  2271.  
  2272.   Revision 5.1  1994/09/03  19:29:08  fjc
  2273.   - Bumped version number
  2274.  
  2275. ***************************************************************************)
  2276.